├── .github └── workflows │ └── build.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── docs ├── CODE_OF_CONDUCT.md └── CONTRIBUTING.md ├── example ├── LICENSE ├── README.md ├── Setup.hs ├── app │ └── Main.hs ├── example.cabal ├── migration │ └── Main.hs ├── src │ ├── Booking │ │ ├── API.hs │ │ ├── Config.hs │ │ ├── Interpreter.hs │ │ └── Types.hs │ ├── CRUD │ │ └── Operations.hs │ └── Schemas │ │ └── Booking.hs └── stack.yaml ├── scalendar.cabal ├── src └── Time │ └── SCalendar │ ├── Internal.hs │ ├── Operations.hs │ ├── Types.hs │ └── Zippers.hs ├── stack.yaml └── test ├── SCalendarTest ├── Arbitrary.hs ├── Constructors.hs ├── Helpers.hs ├── Internal.hs └── Operations.hs └── Test.hs /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | # The present workflow was made based on the following references: 2 | # - https://github.com/actions/cache/blob/main/examples.md#haskell---cabal 3 | # - https://github.com/haskell/time/blob/master/.github/workflows/ci.yml 4 | # - https://github.com/stackbuilders/stache/blob/master/.github/workflows/ci.yaml 5 | # - https://markkarpov.com/post/github-actions-for-haskell-ci.html 6 | --- 7 | name: Build 8 | 9 | on: push 10 | 11 | concurrency: 12 | group: build-${{ github.ref }} 13 | cancel-in-progress: true 14 | 15 | jobs: 16 | haskell: 17 | runs-on: ${{ matrix.os }} 18 | strategy: 19 | matrix: 20 | os: 21 | - macos-latest 22 | - ubuntu-latest 23 | ghc: 24 | - "9.0" 25 | - "8.10" 26 | 27 | steps: 28 | - name: Checkout 29 | uses: actions/checkout@v3 30 | - name: Install Haskell tooling 31 | uses: haskell/actions/setup@v2 32 | with: 33 | ghc-version: ${{ matrix.ghc }} 34 | cabal-version: "3.6" 35 | - name: Configure project 36 | run: cabal configure --enable-tests 37 | - name: Build project 38 | run: cabal build 39 | - name: Run tests 40 | run: cabal test --test-show-details=direct 41 | - name: Check documentation 42 | run: cabal haddock 43 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | .stack-work/ 18 | *~ 19 | 20 | scalendar.db* 21 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | scalendar Change Log 2 | ================== 3 | 4 | 5 | # History Of Changes 6 | ================= 7 | 8 | ## Tue Oct 03 2017 9 | * Version 1.2 with clarified algorithm patent rights and recognition of authorship in README and LICENSE. 10 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | LICENSE 2 | 3 | The MIT License 4 | 5 | Copyright (c) 2017 Sebastian Pulido Gomez and Stack Builders Inc: Implementation 6 | of source code. 7 | 8 | Author Of Algorithm: Martin Rayrole 9 | 10 | 11 | Permission is hereby granted, free of charge, to any person obtaining 12 | a copy of this software and associated documentation files (the 13 | "Software"), to deal in the Software without restriction, including 14 | without limitation the rights to use, copy, modify, merge, publish, 15 | distribute, sublicense, and/or sell copies of the Software, and to 16 | permit persons to whom the Software is furnished to do so, subject to 17 | the following conditions: 18 | 19 | The above copyright notice and this permission notice shall be included 20 | in all copies or substantial portions of the Software. 21 | 22 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 23 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 24 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 25 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 26 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 27 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 28 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 29 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Hackage version](https://img.shields.io/hackage/v/scalendar.svg)](https://hackage.haskell.org/package/scalendar-1.2.0) 2 | [![No Maintenance Intended](http://unmaintained.tech/badge.svg)](http://unmaintained.tech/) 3 | 4 | > **⚠️ Warning:** This library has been deprecated and is no longer maintained. It will not receive any further security patches, features, or bug fixes and is preserved here at GitHub for archival purposes. If you want to use it, we suggest forking the repository and auditing the codebase before use. For more information, contact us at info@stackbuilders.com. 5 | 6 | # DEPRECATED - scalendar: Haskell Library to deal with resource availability in a Calendar. 7 | 8 | This is a library for handling calendars and resource availability based on the 9 | `top-nodes algorithm` and set operations. That's why it is called `scalendar`: Calendars 10 | which which keep track of the availability of a set of resources. 11 | Since the bare `top-nodes algorithm` is not enough to IDENTIFY which are the 12 | specific resources which are available in a given period of time - for example, 13 | the id of the rooms which can still be reserved in a given `(checkIn-checkOut)` 14 | interval - it was necessary to generalize that algorithm to work on sets of 15 | strings which identify the available resources in a period. That generalization 16 | was pretty smooth since addition in numbers was replaced by set Union and substraction 17 | in numbers was replaced by set Difference. Another important fact about sets is that 18 | they do not allow duplicates, so every identifier is guaranteed to be unique. 19 | 20 | 21 | # Introduction 22 | 23 | 24 | ## Data Types 25 | 26 | `scalendar` is a library based on binary trees, where a Calendar is defined as follows: 27 | 28 | ``` 29 | data Calendar = 30 | Unit TimePeriod (Set Text) (Set Text) 31 | | Node TimePeriod (Set Text) (Set Text) Calendar Calendar 32 | 33 | data TimePeriod = 34 | TimeInterval UTCTime UTCTime 35 | | TimeUnit UTCTime 36 | ``` 37 | 38 | The idea is that each node in the calendar will store a TimePeriod which is a data type which stores 39 | a time-interval with an`start-date` and an `end-date`. 40 | 41 | The purpose is that terminal nodes (leaves) will represent a unit of time, `TimeUnit`, which in this case 42 | is a nominal day or 86400 seconds. Thus non-terminal nodes are intended to store a `TimeInterval` and 43 | leaves are intended to store `TimeUnits`. Both leaves and nodes store `Q` and `QN` sets, which are the 44 | data structures which allow the Calendar to keep track of the availability of a set of resources. 45 | For more information about the time representation according to the `top-nodes` 46 | algorithm check [this](https://en.wikipedia.org/wiki/Top-nodes_algorithm) 47 | 48 | Knowing what the `Q` and `QN` sets mean is not quite important to use this library but 49 | roughly: 50 | - `QN(Node)` represents reserved elements for all reservations having this node as `top-node` 51 | - `Q(Node) = U(Q(LeftChild), Q(RightChild)) U QN(Node)` 52 | 53 | In order to use this library, it only suffices to know the meaning of the following 54 | data type: 55 | 56 | ``` 57 | data SCalendar = SCalendar 58 | { calUnits :: Set Text 59 | , calendar :: Calendar 60 | } deriving (Eq, Show) 61 | ``` 62 | 63 | An `SCalendar` is only a product type of a set of identifiers and a group of available resources - for 64 | example, the numbers which are used to identify rooms in a hotel `{"101", "102", ...}` - and a `Calendar`, 65 | which is the tree that keeps track of the availability of that set of resources. 66 | 67 | Other important data types are: 68 | 69 | 70 | - ``` 71 | data Reservation = Reservation 72 | { reservUnits :: Set Text 73 | , reservPeriod :: TimePeriod 74 | } 75 | ``` 76 | 77 | which represents a set of resources we want to reserve over a `TimePeriod` in a `SCalendar`. 78 | 79 | - ``` 80 | data Cancellation = Cancellation 81 | { cancUnits :: Set Text 82 | , cancPeriod :: TimePeriod 83 | } 84 | ``` 85 | 86 | which represents a set of resources we want to cancel over a `TimePeriod` in a `SCalendar` 87 | 88 | - ``` 89 | data Report = Report 90 | { reportPeriod :: TimePeriod 91 | , totalUnits :: Set Text 92 | , reservedUnits :: Set Text 93 | , remainingUnits :: Set Text 94 | } 95 | ``` 96 | which represents a `Report` for a given `TimePeriod` where a `Report` has the following 97 | information: 98 | - `totalUnits`: The set of total identifiers for resources which can be reserved in a 99 | `SCalendar`. 100 | - `reservedUnits`: The set of identifiers for resources which have been reserved for a `TimePeriod`. 101 | - `remainingUnits`: The set of remaining identifiers for resources which can still be 102 | reserved without creating conflicts in a `TimePeriod`. 103 | 104 | 105 | ## Creating a Calendar 106 | 107 | Functions to create Calendars are located in `Time.SCalendar.Types` 108 | 109 | To create a bare `Calendar` which is not associated to any set of identifiers we can use 110 | 111 | ``` 112 | createCalendar :: Integer -- Year. 113 | -> Int -- Month. 114 | -> Int -- Day. 115 | -> Int -- NumDays. 116 | -> Maybe Calendar 117 | ``` 118 | 119 | where 120 | - `Year`: It is an `Integer` representing the starting year of the `Calendar`. For example 121 | `2017`. 122 | - `Month`: It is an `Int` representing the starting month of the `Calendar`. For 123 | example, `2` is equivalent to February. 124 | - `Day`: It is an `Int` representing the starting day of the `Calendar`. It can be 125 | any number representing one of the days of `Month`. 126 | - `NumDays`: It is the number of Days we want our `Calendar` to cover. The days covered 127 | by it will always be a power of `2`. Thus if you input `30`, `createCalendar` will 128 | find the first power of `2` which is greater or equal to `32`, in this case `2^5 = 32`. 129 | 130 | So if everything is ok, this function `Just` returns a new `Calendar` which is suitable for 131 | the given `NumDays`. A new `Calendar` is one which has neither reservations nor cancellations. 132 | 133 | `createSCalendar` is almost like `createCalendar` but instead of returning a bare `Calendar`, 134 | it returns an `SCalendar` which is a `Calendar` together with a set of identifiers (of type `Text`) 135 | which uniquely identify a group of available resources. The following example create an `SCalendar` 136 | of `2 ^ 8 = 512 days` starting from `2016-February-2` with a set of identifiers `{ a, b, c, d }` 137 | 138 | ``` 139 | createSCalendar :: Integer -- Year. 140 | -> Int -- Month. 141 | -> Int -- Day. 142 | -> Int -- NumDays. 143 | -> Set Text -- Set of Identifiers 144 | -> Maybe SCalendar 145 | 146 | createSCalendar 2017 2 1 365 (Set.fromList ["a", "b", "c", "d"]) 147 | ``` 148 | 149 | ## Checking Availability 150 | 151 | There are two functions to check availability for a reservation. The first one is 152 | 153 | ``` 154 | isQuantityAvailable :: Int -> TimePeriod -> SCalendar -> Bool 155 | ``` 156 | 157 | where `Int` is an amount of resource we want to reserve, `TimePeriod` is the period of 158 | time we want to reserve for that amount of resource, and `SCalendar` is the calendar 159 | where we want to check availability. Naturally, this function returns a `Bool` if the 160 | amount of resources is available. 161 | Note that here we are just concerned with the amount of resources and whether there is 162 | some set of identifiers whose size is greater of equal to that amount. If we need 163 | to check if a particular set of identifiers is available for reservation, we can 164 | use the following function: 165 | 166 | ``` 167 | isReservAvailable :: Reservation -> SCalendar -> Bool 168 | ``` 169 | 170 | which is almost like the first function, but here we are taking into account the set 171 | of strings which identifies the resources we want to reserve since we are providing 172 | a `Reservation` as input. 173 | 174 | 175 | ## Adding reservations to a Calendar 176 | 177 | There are two pairs of functions to add reservations to a calendar: 178 | 179 | ``` 180 | reservPeriod' :: Reservation -> Calendar -> Maybe Calendar 181 | ``` 182 | 183 | which inserts reservations into a calendar without any constraint. That's it, this 184 | function does not apply any availability check before making the `Reservation`. That's 185 | why this function does not need a `SCalendar`, because it does not need to take 186 | into account the set of total available resources. 187 | 188 | The safe version is `reservPeriod` (without the quote) which enforces the 189 | `isReservAvailable` check over that reservation before adding it. Its type is 190 | 191 | ``` 192 | reservePeriod :: Reservation -> SCalendar -> Maybe SCalendar 193 | ``` 194 | 195 | where an `SCalendar` is needed because we are taking into account the set of total 196 | available resources to make the validation. 197 | 198 | The other pair of functions are quite similar but are handy for adding a list of 199 | reservations at once: 200 | 201 | ``` 202 | reserveManyPeriods' :: [Reservation] -> Calendar -> Maybe Calendar 203 | ``` 204 | which adds several reservations at once in a Calendar without any availability check. 205 | 206 | ``` 207 | reserveManyPeriods :: [Reservation] -> SCalendar -> Maybe SCalendar 208 | ``` 209 | which will return a `SCalendar` only with the reservations that pass the 210 | `isReservAvailable` test. Here we must take into consideration that reservations will be 211 | inserted in the same order they come in the input list. So, if a reservation conflicts 212 | with the ones that have been already inserted, it will not be included in the `SCalendar`. 213 | 214 | 215 | 216 | ## Removing Reservation: Cancellations 217 | 218 | There are two operations which allow us to remove reserved resources from a period of 219 | time: 220 | 221 | ``` 222 | cancelPeriod :: Cancellation -> Calendar -> Maybe Calendar 223 | ``` 224 | 225 | This operation takes a `Cancellation` and returns a `Calendar` with that `Cancellation`'s 226 | set of resource identifiers subtracted from that `Calendar` in that `Cancellation`'s 227 | period of time. 228 | Be careful with this operation because there is no restriction over the period you are 229 | deleting. You may be deleting from several reservations, from periods of time which are 230 | meaningless - which have already elapsed-, and so on. However, all this library is 231 | intended to be used together with some persistent storage system which will allow you 232 | to keep record of the exact dates and resources which are reserved or cancelled. 233 | 234 | 235 | The other operation is 236 | 237 | ``` 238 | cancelManyPeriods :: [Cancellation] -> Calendar -> Maybe Calendar 239 | ``` 240 | which is handy for cancelling a list of periods at once. 241 | 242 | Note that for cancellations we do not need a `SCalendar` because we don't need to make 243 | any availability check. 244 | 245 | 246 | ## One important thing to note 247 | 248 | Since this calendar implementation uses `Sets` and `Set` operations, you don't have to worry 249 | about things like updating the total number of resource identifiers for your `SCalendar`. 250 | You can freely remove or add identifiers to your `SCalendar` and there will be no 251 | conflicts while making availability checks, reservations, cancellations, and so on. 252 | 253 | 254 | ## Reports 255 | 256 | It is very useful to have an operation which can summarize some information about the 257 | state of the calendar in a given period of time. That's why this library has 258 | 259 | ``` 260 | periodReport :: TimePeriod -> SCalendar -> Maybe Report 261 | ``` 262 | 263 | where `TimePeriod` is the interval of time you would like the `Report` to summarize and 264 | `SCalendar` is the calendar we are working on. This function returns a `Report` over that 265 | period of time with the following information: 266 | - `totalUnits`: The set of total identifiers for resources in the `SCalendar`, 267 | in other words, the set part of `(SCalendar set calendar)`. 268 | - `reservedUnits`: The set of resources which have been reserved for that period of time. 269 | - `remainingUnits`: The set of remaining resources which can still be reserved without 270 | creating conflicts in a `TimePeriod`. 271 | 272 | Note that `totalUnits`, `reservedUnits`, `remainingUnits` are all of type `Set`, and that the type 273 | of `Report` is : 274 | 275 | ``` 276 | data Report = Report 277 | { reportPeriod :: TimePeriod 278 | , totalUnits :: Set Text 279 | , reservedUnits :: Set Text 280 | , remainingUnits :: Set Text 281 | } 282 | ``` 283 | 284 | ## Have Fun! 285 | 286 | So if you find this library useful, have fun with it in applications which need some 287 | sort of calendar and resource availability management!! 288 | 289 | 290 | # Acknowledgements 291 | 292 | The base code for this library was written by [Sebastián Pulido Gómez](https://github.com/sebashack) and 293 | was sponsored by [Stack Builders](https://www.stackbuilders.com/) 294 | 295 | Thanks to [Mark Karpov](https://github.com/mrkkrp) and [Javier Casas](https://github.com/javcasas) for 296 | their code reviews and suggestions. 297 | 298 | 299 | ## Top-Nodes Algorithm Patent information 300 | 301 | The ideas used to implement this library come from an invention by [Martin Rayrole](https://worldwide.espacenet.com/publicationDetails/biblio?locale=en_EP&II=8&FT=D&CC=US&DB=EPODOC&NR=2004204978A1&date=20041014&ND=3&KC=A1&adjacent=true#). 302 | 303 | This version of the algorithm invented by Martin Rayrole now does not have any patent protection. You can verify that by clicking on the `Abandonment` section of this [web-page](https://register.epo.org/ipfwretrieve?lng=en&apn=US.76452604.A). Thus this now belongs to the public domain! 304 | 305 | --- 306 | ## License 307 | 308 | MIT, see [the LICENSE file](LICENSE). 309 | 310 | ## Contributing 311 | 312 | Do you want to contribute to this project? Please take a look at our [contributing guideline](CONTRIBUTING.md) to know how you can help us build it. 313 | 314 | --- 315 | Stack Builders 316 | [Check out our libraries](https://github.com/stackbuilders/) | [Join our team](https://www.stackbuilders.com/join-us/) 317 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /docs/CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Code of conduct 2 | 3 | ## Purpose 4 | The primary goal of this Code of Conduct is to enable an open and welcoming environment. We pledge to making participation in our project a harassment-free experience for everyone, regardless of gender, sexual 5 | orientation, ability, ethnicity, socioeconomic status, and religion (or lack thereof). 6 | 7 | ## General recommendations 8 | Examples of behavior that contributes to creating a positive environment include: 9 | 10 | - Using welcoming and inclusive language 11 | - Being respectful of differing viewpoints and experiences 12 | - Gracefully accepting constructive criticism 13 | - Focusing on what is best for the community 14 | - Showing empathy towards other community members 15 | 16 | Examples of unacceptable behavior by participants include: 17 | 18 | - The use of sexualized language or imagery and unwelcome sexual attention or advances 19 | - Trolling, insulting/derogatory comments, and personal or political attacks 20 | - Public or private harassment 21 | - Publishing others' private information, such as a physical or electronic address, without explicit permission 22 | - Other conduct which could reasonably be considered inappropriate in a professional setting 23 | 24 | ## Maintainer responsibilities 25 | Project maintainers are responsible for clarifying the standards of acceptable behavior and are expected to take appropriate and fair corrective action in response to any instances of unacceptable behavior. 26 | 27 | Project maintainers have the right and responsibility to remove, edit, or reject comments, commits, code, wiki edits, issues, and other contributions that are not aligned to this Code of Conduct, or to ban temporarily or permanently any contributor for other behaviors that they deem inappropriate, threatening, offensive, or harmful. 28 | 29 | ## Scope 30 | This Code of Conduct applies both within project spaces and in public spaces when an individual is representing the project or its community. Examples of representing a project or community include using an official project e-mail address, posting via an official social media account, or acting as an appointed representative at an online or offline event. Representation of a project may be further defined and clarified by project maintainers. 31 | 32 | ## Enforcement 33 | Instances of abusive, harassing, or otherwise unacceptable behavior may be reported by contacting the project team at [community@stackbuilders.com](mailto:community@stackbuilders.com). All complaints will be reviewed and investigated and will result in a response that is deemed necessary and appropriate to the circumstances. The project team is obligated to maintain confidentiality with regard to the reporter of an incident. Further details of specific enforcement policies may be posted separately. 34 | 35 | Project maintainers who do not follow or enforce the Code of Conduct in good faith may face temporary or permanent repercussions as determined by other members of the project's leadership. 36 | -------------------------------------------------------------------------------- /docs/CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contribution Guide 2 | 3 | Thank you for your interest in contributing to this Stack Builders' library. To contribute, please take our [Code of Conduct](CODE_OF_CONDUCT.md) into account, along with the following recommendations: 4 | 5 | - When submitting contributions to this repository, please make sure to discuss with the maintainer(s) the change you want to make. You can do this through an issue, or by sending an email to [community@stackbuilders.com](mailto:community@stackbuilders.com) 6 | 7 | - Once the change has been discussed with the maintainer(s), feel free to open a Pull Request. Please include a link to the issue you're trying to solve, or a quick summary of the discussed changes. 8 | 9 | - If adding any new features that you think should be considered in the README file, please add that information in your Pull Request. 10 | 11 | - Once you get an approval from any of the maintainers, please merge your Pull Request. Keep in mind that some of our Stack Builders repositories use CI/CD pipelines, so you will need to pass all of the required checks before merging. 12 | 13 | ## Getting help 14 | Contact any of our current maintainers, or send us an email at [community@stackbuilders.com](mailto:community@stackbuilders.com) for more information. Thank you for contributing! 15 | -------------------------------------------------------------------------------- /example/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /example/README.md: -------------------------------------------------------------------------------- 1 | # scalendar example 2 | 3 | 4 | # Introduction 5 | 6 | Imagine that you have a small hotel with 20 rooms that you have identified from 7 | `room-100` to `room-120`. This example implements a small [Servant-API](https://haskell-servant.readthedocs.io/en/stable/) 8 | to get information about its reservation history starting from `January 1th of 2018`. 9 | 10 | The API exposes 4 endpoints for: 11 | 12 | - creating a reservation for a given time period. 13 | 14 | - returning a set of available rooms in a given time period. 15 | 16 | - determining if a given room is available in a time period. 17 | 18 | - returning an availability report of the hotel in a time period. 19 | 20 | 21 | # Running the example 22 | 23 | 1. Build the project: 24 | 25 | ``` 26 | stack build 27 | ``` 28 | 29 | 2. Run the `sqlite` migrations 30 | 31 | ``` 32 | stack exec runMigration 33 | ``` 34 | 35 | 3. Start the server 36 | ``` 37 | stack exec runExample 38 | ``` 39 | 40 | The server will start running on port `3000`. 41 | 42 | 43 | # Example requests to the server 44 | 45 | You can send requests to the server with a client application like [curl](https://curl.haxx.se/). Let's 46 | try some example requests: 47 | 48 | 1. Reserving rooms `101`, `102` and `103` from February 15th to February 20th of 2017 49 | 50 | ``` 51 | curl -iXPOST localhost:3000/hotelbooking/booking -H "Content-Type: application/json" -d '{ 52 | "name": "Jeremy", 53 | "check": { 54 | "checkIn": "2017-02-15T00:00:00Z", 55 | "checkOut": "2017-02-20T00:00:00Z" 56 | }, 57 | "roomIds": ["101", "102", "103"] 58 | }' 59 | ``` 60 | 61 | 2. Determining if room `101` is available from February 17th to February 21th of 2017 62 | 63 | 64 | ``` 65 | curl -iXGET localhost:3000/hotelbooking/isRoomAvailable/101 -H "Content-Type: application/json" -d '{ 66 | "checkIn": "2017-02-17T00:00:00Z", 67 | "checkOut": "2017-02-21T00:00:00Z" 68 | }' 69 | ``` 70 | 71 | If you made the above reservation, you should get a `false` from the server meaning that that room 72 | is not available for that period of time. 73 | 74 | 75 | 3. Returning an availabilty report from February 10th to February 20th of 2017 76 | 77 | ``` 78 | curl -iXGET localhost:3000/hotelbooking/getPeriodicReport -H "Content-Type: application/json" -d '{ 79 | "checkIn": "2017-02-10T00:00:00Z", 80 | "checkOut": "2017-02-20T00:00:00Z" 81 | }' 82 | ``` 83 | 84 | If you made the above reservation, the set of reserved rooms for that period of time should include `101`, 85 | `102` and `103`. 86 | 87 | 88 | 4. Returning the rooms which are still available from February 10th to February 20th of 2017 89 | 90 | ``` 91 | curl -iXGET localhost:3000/hotelbooking/getAvailableRooms -H "Content-Type: application/json" -d '{ 92 | "checkIn": "2017-02-10T00:00:00Z", 93 | "checkOut": "2017-02-20T00:00:00Z" 94 | }' 95 | ``` 96 | 97 | If you made the above reservation, you should get all the rooms except `101`, `102` and `103`. 98 | 99 | 100 | 101 | # Business Model Constraints and Calendars 102 | 103 | In this example implementation we have assumed that hotel reservations must be less than 30 days. 104 | That's why if we need to calculate the availability of a reservation from, say, February 10th to February 20th of 2017, 105 | we do not have to retrieve all the reservations stored in DB and fill the calendar with them, which would be inefficient. 106 | We just need to retrieve the reservations included in an interval of the form `(February 10th - 30 days, February 20th + 30 days)`, 107 | and that's all the Calendar needs to correctly determine the availabilty of a reservation from February 10th to 20th - 108 | this only holds if you properly store reservations in DB taking care that if they are not less than 30 days, 109 | then they cannot be performed. 110 | 111 | In general, you should detect if your use case has this kind of time reservation constraint for N days - which 112 | is generally the case since nothing can be reserved forever -, and only allow the storage in DB of reservations less 113 | than N days. Then, when building a Calendar, you should only fetch reservations within a time interval of the form 114 | `(start-date - N, end-date + N)`. -------------------------------------------------------------------------------- /example/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /example/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Booking.Config (exampleConf) 4 | import Booking.Interpreter (bookingProxy, server) 5 | import Network.Wai 6 | import Network.Wai.Handler.Warp 7 | import Network.Wai.Middleware.RequestLogger 8 | import Servant (serve) 9 | 10 | main :: IO () 11 | main = do 12 | putStrLn "Server running on localhost:3000" 13 | run 3000 $ logStdoutDev (serve bookingProxy $ server exampleConf) 14 | -------------------------------------------------------------------------------- /example/example.cabal: -------------------------------------------------------------------------------- 1 | name: example 2 | version: 0.1.0.0 3 | homepage: https://github.com/githubuser/example#readme 4 | license: BSD3 5 | license-file: LICENSE 6 | author: Author name here 7 | maintainer: example@example.com 8 | copyright: 2017 Author name here 9 | category: Web 10 | build-type: Simple 11 | extra-source-files: README.md 12 | cabal-version: >=1.10 13 | 14 | library 15 | hs-source-dirs: src 16 | exposed-modules: Booking.Types 17 | , Booking.API 18 | , Booking.Config 19 | , Booking.Interpreter 20 | , Schemas.Booking 21 | , CRUD.Operations 22 | build-depends: base >= 4.8 && < 5 23 | , persistent-sqlite >= 2.5 && <= 2.6.2 24 | , persistent-template == 2.5.2 25 | , persistent >= 2.5 && <= 2.7.0 26 | , time 27 | , text 28 | , containers 29 | , mtl == 2.2.1 30 | , servant == 0.9.1.1 31 | , servant-server 32 | , bytestring 33 | , aeson >= 1.0.2.1 && <= 1.2.1.0 34 | , scalendar 35 | default-language: Haskell2010 36 | 37 | executable runExample 38 | hs-source-dirs: app 39 | main-is: Main.hs 40 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 41 | build-depends: base 42 | , example 43 | , servant == 0.9.1.1 44 | , servant-server 45 | , wai-extra 46 | , wai == 3.2.1.1 47 | , warp 48 | default-language: Haskell2010 49 | 50 | executable runMigration 51 | hs-source-dirs: migration 52 | main-is: Main.hs 53 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 54 | build-depends: base 55 | , example 56 | default-language: Haskell2010 57 | -------------------------------------------------------------------------------- /example/migration/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Booking.Config (exampleConf) 4 | import Schemas.Booking (runBookingMigration) 5 | 6 | main :: IO () 7 | main = runBookingMigration exampleConf 8 | -------------------------------------------------------------------------------- /example/src/Booking/API.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | 4 | module Booking.API where 5 | 6 | import Booking.Types 7 | import Data.Set (Set) 8 | import Data.Text (Text) 9 | import Servant 10 | 11 | 12 | type RoomId = Text 13 | 14 | type BookingAPI = "hotelbooking" :> 15 | ( 16 | -- ^ 1) Return a set of availables rooms based on the CheckInOut dates. 17 | "getAvailableRooms" :> ReqBody '[JSON] CheckInOut :> Get '[JSON] (Set RoomId) 18 | 19 | -- ^ 2) Return a boolean if the given RoomId is available. 20 | :<|> "isRoomAvailable" :> Capture "roomId" RoomId :> ReqBody '[JSON] CheckInOut :> Get '[JSON] Bool 21 | 22 | -- ^ 3) Return a report of the current state of reservations in the given period of time. 23 | :<|> "getPeriodicReport" :> ReqBody '[JSON] CheckInOut :> Get '[JSON] Report 24 | 25 | -- ^ 4) Creates a reservation based on a Reservation data. 26 | :<|> "booking" :> ReqBody '[JSON] ReservationInfo :> Post '[JSON] Reservation 27 | ) 28 | -------------------------------------------------------------------------------- /example/src/Booking/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Booking.Config where 4 | 5 | import Booking.Types (ConfigDB (..)) 6 | 7 | exampleConf :: ConfigDB 8 | exampleConf = Config { path = "scalendar.db" } 9 | -------------------------------------------------------------------------------- /example/src/Booking/Interpreter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | module Booking.Interpreter where 6 | 7 | import Booking.API 8 | import Booking.Types 9 | import Control.Monad (mapM) 10 | import Control.Monad.Except 11 | import Control.Monad.Reader 12 | import CRUD.Operations 13 | import Data.Monoid ((<>)) 14 | import Data.Proxy 15 | import Data.Set (Set) 16 | import qualified Data.Set as S (fromList, toList) 17 | import Data.Text (Text) 18 | import qualified Data.Text as T (pack, unpack) 19 | import Data.Time ( UTCTime (..) 20 | , NominalDiffTime 21 | , addUTCTime 22 | , toGregorian 23 | , diffDays ) 24 | import Data.ByteString.Lazy (ByteString) 25 | import Servant 26 | import Time.SCalendar.Operations ( isReservAvailable 27 | , reserveManyPeriods' 28 | , periodReport ) 29 | import qualified Time.SCalendar.Types as SC (Reservation, Report(..)) 30 | import Time.SCalendar.Types ( SCalendar (..) 31 | , TimePeriod 32 | , createSCalendar 33 | , makeReservation 34 | , makeTimePeriod ) 35 | 36 | 37 | -- 38 | -- Calendar constants -- 39 | 40 | -- | Total rooms in our imaginary hotel represented as ids from 100 to 120. 41 | totalRooms :: Set Text 42 | totalRooms = S.fromList $ (T.pack . show) <$> ([100..120] :: [Int]) 43 | 44 | -- | For simplicity we are assuming that all the reservations are made in a one 45 | -- year Calendar starting starting from January 1th of 2017. 46 | calendarYear :: Integer 47 | calendarYear = 2017 48 | 49 | calendarDay :: Int 50 | calendarDay = 1 51 | 52 | calendarMonth :: Int 53 | calendarMonth = 1 54 | 55 | calendarSpan :: Int 56 | calendarSpan = 365 57 | -- -- 58 | 59 | thirtyDays :: NominalDiffTime -- ^ Thirty days in seconds 60 | thirtyDays = 2592000 61 | 62 | intervalErrorMsg :: ByteString 63 | intervalErrorMsg = "Invalid time interval: Check-Out must be greater than or " 64 | <> "equal to Check-In and the interval should not span more " 65 | <> "than 29 days." 66 | 67 | -- 68 | -- Handlers -- 69 | 70 | getAvailableRooms :: CheckInOut -> App (Set RoomId) 71 | getAvailableRooms (Check cIn cOut) = do 72 | scalendar <- getSCalendarWithReservs (cIn, cOut) 73 | period <- liftMaybe err500 $ getTimePeriodFromUTC cIn cOut 74 | (SC.Report _ _ _ remaining') <- liftMaybe (err404 { errBody = "Invalid time check-in and check-out" }) $ 75 | periodReport period scalendar 76 | pure remaining' 77 | 78 | checkReservation :: Text -> CheckInOut -> App Bool 79 | checkReservation roomId (Check cIn cOut) = do 80 | scalendar <- getSCalendarWithReservs (cIn, cOut) 81 | reservToCheck <- liftMaybe err500 $ tupleToReserv (cIn, cOut, T.pack . show $ [roomId]) 82 | pure $ isReservAvailable reservToCheck scalendar 83 | 84 | getReport :: CheckInOut -> App Report 85 | getReport (Check cIn cOut) = do 86 | scalendar <- getSCalendarWithReservs (cIn, cOut) 87 | period <- liftMaybe err500 $ getTimePeriodFromUTC cIn cOut 88 | (SC.Report _ total' reserved' remaining') <- liftMaybe (err404 { errBody = "Invalid time check-in and check-out" }) $ 89 | periodReport period scalendar 90 | pure $ Report total' reserved' remaining' 91 | 92 | postReservation :: ReservationInfo -> App Reservation 93 | postReservation reservInfo@(ReservationInfo name' (Check cIn cOut) roomIds') = do 94 | liftMaybe (err400 { errBody = intervalErrorMsg }) $ isValidTimeInterval (cIn, cOut) 95 | scalendar <- getSCalendarWithReservs (cIn, cOut) 96 | reservToCheck <- liftMaybe err500 $ tupleToReserv (cIn, cOut, ids) 97 | if isReservAvailable reservToCheck scalendar 98 | then 99 | runAction $ insertReservation name' (cIn, cOut) ids >>= pure . flip Reservation reservInfo 100 | else 101 | lift $ throwError (err400 { errBody = "Invalid Reservation" }) 102 | where 103 | ids = (T.pack . show) $ S.toList roomIds' 104 | 105 | 106 | -- 107 | -- Helpers -- 108 | 109 | -- | Given a time interval (start, end), this functions creates an SCalendar 110 | -- filled with the reservations included in the interval (start - 30 days, end + 30 days). 111 | -- This is appropriate for hotels since a reservation must be less than 30 days. 112 | -- Note that we do not need to fill the calendar with all reservations from DB, but if 113 | -- you have constraints for your reservations in your business model, say, a reservation 114 | -- cannot be more than N days, then you just have to fill your calendar with 115 | -- the reservations included in (start - N, end - N). 116 | getSCalendarWithReservs :: (UTCTime, UTCTime) 117 | -> App SCalendar 118 | getSCalendarWithReservs (cIn, cOut) = do 119 | let cIn' = (-thirtyDays) `addUTCTime` cIn 120 | cOut' = thirtyDays `addUTCTime` cOut 121 | calReservs <- runAction (getReservationsFromPeriod (cIn', cOut')) >>= tuplesToCalReservs 122 | (SCalendar _ cal) <- liftMaybe err500 $ 123 | createSCalendar calendarYear calendarDay calendarMonth calendarSpan totalRooms 124 | calWithReservs <- liftMaybe err500 $ reserveManyPeriods' calReservs cal 125 | pure $ SCalendar totalRooms calWithReservs 126 | 127 | -- | Valid hotel reservations are greater than one day but less than 30 days. 128 | isValidTimeInterval :: (UTCTime, UTCTime) -> Maybe () 129 | isValidTimeInterval (UTCTime gregDayIn _, UTCTime gregDayOut _) = 130 | let numDays = fromIntegral $ diffDays gregDayOut gregDayIn 131 | in if numDays < 30 && numDays > 0 then Just () else Nothing 132 | 133 | -- | Create a TimePeriod from start and end dates. 134 | getTimePeriodFromUTC :: UTCTime -> UTCTime -> Maybe TimePeriod 135 | getTimePeriodFromUTC (UTCTime gregDayIn _) (UTCTime gregDayOut _) = 136 | let numDays = fromIntegral $ diffDays gregDayOut gregDayIn 137 | (year, month, day) = toGregorian gregDayIn 138 | in makeTimePeriod year month day numDays 139 | 140 | tuplesToCalReservs :: [(a, b, UTCTime, UTCTime, Text)] -> App [SC.Reservation] 141 | tuplesToCalReservs tupReservs = liftMaybe err500 $ 142 | mapM (tupleToReserv . (\(_, _, a, b, c) -> (a, b, c))) tupReservs 143 | 144 | liftMaybe :: ServantErr -> Maybe a -> App a 145 | liftMaybe err Nothing = lift $ throwError err 146 | liftMaybe _ (Just a) = pure a 147 | 148 | tupleToReserv :: (UTCTime, UTCTime, Text) -> Maybe SC.Reservation 149 | tupleToReserv (cIn', cOut', ids') = 150 | getTimePeriodFromUTC cIn' cOut' >>= 151 | flip makeReservation (S.fromList $ T.pack <$> (read . T.unpack) ids') 152 | 153 | 154 | -- 155 | -- Application Server -- 156 | 157 | runContext :: ConfigDB -> App :~> Handler 158 | runContext config = Nat $ flip runReaderT config 159 | 160 | bookingProxy :: Proxy BookingAPI 161 | bookingProxy = Proxy 162 | 163 | handlers :: ServerT BookingAPI App 164 | handlers = getAvailableRooms 165 | :<|> checkReservation 166 | :<|> getReport 167 | :<|> postReservation 168 | 169 | server :: ConfigDB -> Server BookingAPI 170 | server config = enter (runContext config) handlers 171 | -------------------------------------------------------------------------------- /example/src/Booking/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Booking.Types where 6 | 7 | import Control.Monad.Except 8 | import Control.Monad.Reader 9 | import Data.Aeson 10 | import Data.Set (Set) 11 | import Data.Text (Text) 12 | import Data.Time (UTCTime) 13 | import Database.Persist.Sql 14 | import Database.Persist.Sqlite 15 | import GHC.Generics 16 | import Servant 17 | 18 | 19 | -- 20 | -- Application type -- 21 | 22 | type App = ReaderT ConfigDB (ExceptT ServantErr IO) 23 | 24 | newtype ConfigDB = Config { 25 | path :: Text 26 | } deriving Show 27 | 28 | runAction :: SqlPersistM a -> App a -- ^ run DB actions in App context 29 | runAction action = reader path >>= liftIO . flip runSqlite action 30 | 31 | 32 | -- 33 | -- Booking Types -- 34 | 35 | data CheckInOut = Check { 36 | checkIn :: UTCTime 37 | , checkOut :: UTCTime 38 | } deriving (Show, Generic, Ord, Eq) 39 | 40 | data Reservation = Reservation { 41 | id :: Integer 42 | , reservationInfo :: ReservationInfo 43 | } deriving (Show, Generic) 44 | 45 | data ReservationInfo = ReservationInfo { 46 | name :: Text 47 | , check :: CheckInOut 48 | , roomIds :: Set Text 49 | } deriving (Show, Generic) 50 | 51 | data Report = Report { 52 | total :: Set Text -- ^ Total rooms in our imaginary hotel. 53 | , reserved :: Set Text -- ^ Rooms which have been already reserved. 54 | , remaining :: Set Text -- ^ Rooms which are still available. 55 | } deriving (Show, Generic) 56 | 57 | 58 | -- 59 | -- FromJSON and ToJSON instances -- 60 | 61 | instance FromJSON CheckInOut 62 | instance ToJSON CheckInOut 63 | 64 | instance FromJSON Reservation 65 | instance ToJSON Reservation 66 | 67 | instance FromJSON ReservationInfo 68 | instance ToJSON ReservationInfo 69 | 70 | instance FromJSON Report 71 | instance ToJSON Report 72 | -------------------------------------------------------------------------------- /example/src/CRUD/Operations.hs: -------------------------------------------------------------------------------- 1 | module CRUD.Operations where 2 | 3 | import Data.Text (Text) 4 | import Data.Time (UTCTime) 5 | import Database.Persist.Sql 6 | import Schemas.Booking 7 | 8 | 9 | insertReservation :: Text 10 | -> (UTCTime, UTCTime) -- ^ check-in and check-out. 11 | -> Text -- ^ Set of rooms in text representation, e.g., "[101, 102, 103]". 12 | -> SqlPersistM Integer -- ^ Id of the created reservation in DB. 13 | insertReservation name (cin, cout) rooms = 14 | insert (Reservation name cin cout rooms) >>= pure . fromIntegerTokey 15 | 16 | -- | Get reservations in DB included in a given interval of time. 17 | getReservationsFromPeriod :: (UTCTime, UTCTime) 18 | -> SqlPersistM [(Integer, Text, UTCTime, UTCTime, Text)] 19 | getReservationsFromPeriod (cIn, cOut) = do 20 | entities <- selectList [ ReservationCheckIn >=. cIn 21 | , ReservationCheckIn <=. cOut 22 | , ReservationCheckOut >=. cIn 23 | , ReservationCheckOut <=. cOut ] [] 24 | pure $ (\(Entity key (Reservation name cin cout rooms)) 25 | -> (fromIntegerTokey key, name, cin, cout, rooms)) <$> entities 26 | 27 | fromIntegerTokey :: Key Reservation -> Integer 28 | fromIntegerTokey = toInteger . unSqlBackendKey . unReservationKey 29 | -------------------------------------------------------------------------------- /example/src/Schemas/Booking.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE QuasiQuotes #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | 9 | module Schemas.Booking where 10 | 11 | import Booking.Types (ConfigDB (..)) 12 | import Data.Text (Text) 13 | import Data.Time (UTCTime) 14 | import Database.Persist.Sql (runMigration) 15 | import Database.Persist.Sqlite 16 | import Database.Persist.TH 17 | 18 | 19 | share [mkPersist sqlSettings, mkMigrate "migrateBooking"] [persistLowerCase| 20 | Reservation 21 | name Text 22 | checkIn UTCTime 23 | checkOut UTCTime 24 | roomIds Text 25 | deriving Show 26 | |] 27 | 28 | runBookingMigration :: ConfigDB -> IO () 29 | runBookingMigration conf = runSqlite (path conf) $ runMigration migrateBooking 30 | -------------------------------------------------------------------------------- /example/stack.yaml: -------------------------------------------------------------------------------- 1 | packages: 2 | - '.' 3 | - location: 4 | git: git@github.com:stackbuilders/scalendar.git 5 | commit: 01508a511d416af8069d351bdfa4cf83b55db401 6 | subdirs: [] 7 | extra-dep: true 8 | extra-deps: 9 | - SCalendar-0.1.0.0 10 | resolver: lts-8.19 11 | -------------------------------------------------------------------------------- /scalendar.cabal: -------------------------------------------------------------------------------- 1 | name: scalendar 2 | version: 1.2.0 3 | tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.1 4 | synopsis: A library for handling calendars and resource availability over time. 5 | description: scalendar is a library based on the "top-nodes algorithm", invented by 6 | Martin Rayrole , and 7 | set operations, which makes it easy to handle the availability of a set of 8 | resources over time. 9 | 10 | homepage: https://github.com/stackbuilders/scalendar 11 | license: MIT 12 | license-file: LICENSE 13 | copyright: 2017 Stack Builders Inc. 14 | author: Sebastian Pulido Gómez 15 | maintainer: Stack Builders 16 | category: Time 17 | build-type: Simple 18 | cabal-version: >=1.10 19 | extra-source-files: CHANGELOG.md 20 | , README.md 21 | 22 | library 23 | hs-source-dirs: src 24 | exposed-modules: Time.SCalendar.Operations 25 | , Time.SCalendar.Zippers 26 | , Time.SCalendar.Types 27 | , Time.SCalendar.Internal 28 | build-depends: base >= 4.8 && < 5 29 | , containers >= 0.5.7.1 && < 0.6 30 | , time >= 1.5 && < 2 31 | , text >= 1.2.0.0 && < 2 32 | default-language: Haskell2010 33 | 34 | test-suite scalendar-test 35 | type: exitcode-stdio-1.0 36 | hs-source-dirs: test 37 | other-modules: SCalendarTest.Internal 38 | , SCalendarTest.Operations 39 | , SCalendarTest.Arbitrary 40 | , SCalendarTest.Helpers 41 | , SCalendarTest.Constructors 42 | main-is: Test.hs 43 | build-depends: base 44 | , scalendar 45 | , hspec >= 2.4.2 && < 3.0 46 | , QuickCheck >= 2.9.2 && < 3.0 47 | , time 48 | , containers 49 | , text 50 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 51 | default-language: Haskell2010 52 | -------------------------------------------------------------------------------- /src/Time/SCalendar/Internal.hs: -------------------------------------------------------------------------------- 1 | module Time.SCalendar.Internal 2 | ( getInterval 3 | , daysBetween 4 | , goToNode 5 | , updateQ 6 | , intervalFitsCalendar 7 | , checkQuantAvailability 8 | , checkReservAvailability 9 | , updateCalendar 10 | , topMostNodes 11 | , leftMostTopNode 12 | , rightMostTopNode 13 | , commonParent 14 | , getZipInterval 15 | , getQMax 16 | ) where 17 | 18 | 19 | import Data.Text (Text) 20 | import Data.Time (UTCTime) 21 | import Data.Set (Set, union, unions, size, difference, isSubsetOf) 22 | import Data.Maybe (listToMaybe, maybe) 23 | import Control.Monad (guard) 24 | import Time.SCalendar.Zippers 25 | import Time.SCalendar.Types 26 | import qualified Data.Time as TM (diffUTCTime) 27 | 28 | 29 | daysBetween :: UTCTime -> UTCTime -> Int 30 | daysBetween from to = 1 + round (TM.diffUTCTime to from / oneDay) 31 | 32 | intervalFitsCalendar :: TimePeriod -> Calendar -> Bool 33 | intervalFitsCalendar interval1 (Node interval2 _ _ _ _) = 34 | isIncluded (toTimeUnit interval1) (toTimeUnit interval2) 35 | intervalFitsCalendar _ _ = False 36 | 37 | getInterval :: Calendar -> TimePeriod 38 | getInterval (Unit unit _ _) = unit 39 | getInterval (Node interval _ _ _ _) = toTimeUnit interval 40 | 41 | getZipInterval :: CalendarZipper -> TimePeriod 42 | getZipInterval (node, _) = (toTimeUnit . getInterval) node 43 | 44 | getQ :: CalendarZipper -> Set Text 45 | getQ (Unit _ q _, _) = q 46 | getQ (Node _ q _ _ _, _) = q 47 | 48 | getQN :: CalendarZipper -> Set Text 49 | getQN (Unit _ _ qn, _) = qn 50 | getQN (Node _ _ qn _ _, _) = qn 51 | 52 | getQMax :: CalendarZipper -> Maybe (Set Text) 53 | getQMax zipper@(_, []) = Just $ getQ zipper 54 | getQMax zipper = do 55 | parent <- goUp zipper 56 | go parent (getQ zipper) 57 | where 58 | go zipper@(_, []) sum = do 59 | let qn = getQN zipper 60 | return $ union sum qn 61 | go zipper sum = do 62 | let qn = getQN zipper 63 | parent <- goUp zipper 64 | go parent $ union sum qn 65 | 66 | leftMostTopNode :: TimePeriod 67 | -> Calendar 68 | -> Maybe CalendarZipper 69 | leftMostTopNode interval calendar = do 70 | guard $ intervalFitsCalendar interval calendar 71 | result <- ltmNode (getFrom interval, getTo interval) (toZipper calendar) 72 | listToMaybe result 73 | where 74 | ltmNode (lower, upper) zipper@(Unit t _ _, _) 75 | | lower == getFrom t && getFrom t <= upper = Just [zipper] 76 | | otherwise = Just [] 77 | ltmNode i@(lower, upper) node@(Node t _ _ _ _, _) = do 78 | let (from, to) = (getFrom t, getTo t) 79 | (lChild, bsl) <- goLeft node 80 | (rChild, bsr) <- goRight node 81 | if lower == from && to <= upper 82 | then Just [node] 83 | else do 84 | let toL = (getTo . getInterval) lChild 85 | fromR = (getFrom . getInterval) rChild 86 | lAnswer <- 87 | if lower <= toL 88 | then ltmNode i (lChild, bsl) 89 | else Just [] 90 | rAnswer <- 91 | if lower >= fromR 92 | then ltmNode i (rChild, bsr) 93 | else Just [] 94 | return $ lAnswer ++ rAnswer 95 | 96 | rightMostTopNode :: TimePeriod 97 | -> Calendar 98 | -> Maybe CalendarZipper 99 | rightMostTopNode interval calendar = do 100 | guard $ intervalFitsCalendar interval calendar 101 | result <- rtmNode (getFrom interval, getTo interval) (toZipper calendar) 102 | listToMaybe result 103 | where 104 | rtmNode (lower, upper) zipper@(Unit t _ _, _) 105 | | upper == getFrom t && getFrom t >= lower = Just [zipper] 106 | | otherwise = Just [] 107 | rtmNode i@(lower, upper) node@(Node t _ _ _ _, _) = do 108 | let (from, to) = (getFrom t, getTo t) 109 | (lChild, bsl) <- goLeft node 110 | (rChild, bsr) <- goRight node 111 | if upper == to && from >= lower 112 | then Just [node] 113 | else do 114 | let toL = (getTo . getInterval) lChild 115 | fromR = (getFrom . getInterval) rChild 116 | lAnswer <- 117 | if upper <= toL 118 | then rtmNode i (lChild, bsl) 119 | else Just [] 120 | rAnswer <- 121 | if upper >= fromR 122 | then rtmNode i (rChild, bsr) 123 | else Just [] 124 | return $ lAnswer ++ rAnswer 125 | 126 | commonParent :: CalendarZipper -> CalendarZipper -> Maybe CalendarZipper 127 | commonParent zipper1@(node1, bs1) zipper2@(node2, bs2) = do 128 | let bs1Length = length bs1 129 | bs2Length = length bs2 130 | interval1 = getInterval node1 131 | interval2 = getInterval node2 132 | case bs1Length `compare` bs2Length of 133 | LT -> do 134 | zipper2' <- goUp zipper2 135 | commonParent zipper1 zipper2' 136 | EQ -> 137 | if interval1 == interval2 138 | then Just zipper1 139 | else do 140 | zipper1' <- goUp zipper1 141 | zipper2' <- goUp zipper2 142 | commonParent zipper1' zipper2' 143 | GT -> do 144 | zipper1' <- goUp zipper1 145 | commonParent zipper1' zipper2 146 | 147 | topMostNodes :: TimePeriod 148 | -> Calendar 149 | -> Maybe [CalendarZipper] 150 | topMostNodes interval calendar = do 151 | rtNode <- rightMostTopNode (toTimeUnit interval) calendar 152 | let intervalR = getZipInterval rtNode 153 | if intervalR == interval 154 | then return [rtNode] 155 | else do 156 | ltNode <- leftMostTopNode interval calendar 157 | let intervalL = getZipInterval ltNode 158 | parent <- commonParent ltNode rtNode 159 | answer <- goDownTree (toTimeUnit interval) intervalL intervalR parent 160 | return $ ltNode : rtNode : answer 161 | where 162 | goDownTree period leftMost rightMost zipper@(Unit t _ _, _) = 163 | if isIncluded t period 164 | then if t == rightMost || t == leftMost 165 | then Just [] 166 | else Just [zipper] 167 | else Just [] 168 | goDownTree period leftMost rightMost node@(Node t _ _ _ _, _) = 169 | if isIncluded t period 170 | then if t == rightMost || t == leftMost 171 | then Just [] 172 | else Just [node] 173 | else do 174 | lChild <- goLeft node 175 | rChild <- goRight node 176 | lAnswer <- goDownTree period leftMost rightMost lChild 177 | rAnswer <- goDownTree period leftMost rightMost rChild 178 | return $ lAnswer ++ rAnswer 179 | 180 | updateQ :: CalendarZipper -> Maybe CalendarZipper 181 | updateQ zipper@(node, []) = Just zipper 182 | updateQ zipper = do 183 | parent <- goUp zipper 184 | lChild <- goLeft parent 185 | rChild <- goRight parent 186 | let (Node period q qn left right, bs) = parent 187 | lQ = getQ lChild 188 | rQ = getQ rChild 189 | updateQ (Node period (unions [lQ, rQ, qn]) qn left right, bs) 190 | 191 | goToNode :: TimePeriod -> Calendar -> Maybe CalendarZipper 192 | goToNode interval calendar = do 193 | result <- go (toTimeUnit interval) (toZipper calendar) 194 | listToMaybe result 195 | where 196 | go interval zipper@(Unit t _ _, _) 197 | | interval == t = Just [zipper] 198 | | otherwise = Just [] 199 | go interval node@(Node t _ _ _ _, bs) = 200 | if interval == t 201 | then Just [node] 202 | else do 203 | (lChild, bsl) <- goLeft node 204 | (rChild, bsr) <- goRight node 205 | let (lower, upper) = (getFrom interval, getTo interval) 206 | toL = (getTo . getInterval) lChild 207 | fromR = (getFrom . getInterval) rChild 208 | lAnswer <- if lower >= fromR 209 | then Just [] 210 | else go interval (lChild, bsl) 211 | rAnswer <- if upper <= toL 212 | then Just [] 213 | else go interval (rChild, bsr) 214 | return $ lAnswer ++ rAnswer 215 | 216 | updateCalendar :: [TimePeriod] 217 | -> Set Text 218 | -> Calendar 219 | -> (Set Text -> Set Text -> Maybe (Set Text)) 220 | -> Maybe Calendar 221 | updateCalendar [] _ cal _ = Just cal 222 | updateCalendar (interval:ins) elts cal f = do 223 | updatedRoot <- updateQandQN elts (toTimeUnit interval) cal 224 | updateCalendar ins elts updatedRoot f 225 | where 226 | update s (Unit unit q qn, bs) = do 227 | newQ <- f q s 228 | newQN <- f qn s 229 | let zipper = (Unit unit newQ newQN, bs) 230 | updateQ zipper 231 | update s (Node interval q qn left right, bs) = do 232 | newQ <- f q s 233 | newQN <- f qn s 234 | let zipper = (Node interval newQ newQN left right, bs) 235 | updateQ zipper 236 | 237 | updateQandQN set interval cal = do 238 | zipper <- goToNode interval cal 239 | updatedZip <- update set zipper 240 | (root, _) <- upToRoot updatedZip 241 | return root 242 | 243 | checkQuantAvailability :: TimePeriod 244 | -> Int 245 | -> Set Text 246 | -> CalendarZipper 247 | -> Bool 248 | checkQuantAvailability interval qt units zipper = 249 | maybe False (not . null) $ checkAvailability interval qt units zipper 250 | where 251 | checkAvailability _ qt units zipper@(Unit {}, _) = do 252 | qMax <- getQMax zipper 253 | let avUnits = size (difference units qMax) 254 | if qt <= avUnits 255 | then Just [()] 256 | else Nothing 257 | checkAvailability interval qt units node@(Node t _ _ _ _, _) = do 258 | qMax <- getQMax node 259 | let avUnits = size (difference units qMax) 260 | guard $ qt <= avUnits || not (isIncluded t interval) 261 | (lChild, bsl) <- goLeft node 262 | (rChild, bsr) <- goRight node 263 | let (lower, upper) = (getFrom interval, getTo interval) 264 | toL = (getTo . getInterval) lChild 265 | fromR = (getFrom . getInterval) rChild 266 | lAnswer <- 267 | if lower >= fromR 268 | then Just [] 269 | else checkAvailability interval qt units (lChild, bsl) 270 | rAnswer <- 271 | if upper <= toL 272 | then Just [] 273 | else checkAvailability interval qt units (rChild, bsr) 274 | return $ lAnswer ++ rAnswer 275 | 276 | checkReservAvailability :: Reservation 277 | -> Set Text 278 | -> CalendarZipper 279 | -> Bool 280 | checkReservAvailability reservation units zipper = 281 | maybe False (not . null) $ checkAvailability reservation units zipper 282 | where 283 | checkAvailability reservation units zipper@(Unit {}, _) = do 284 | qMax <- getQMax zipper 285 | let avUnits = difference units qMax 286 | isSubset = isSubsetOf (reservUnits reservation) avUnits 287 | if isSubset 288 | then Just [()] 289 | else Nothing 290 | checkAvailability reservation units node@(Node t _ _ _ _, _) = do 291 | qMax <- getQMax node 292 | let interval = (toTimeUnit . reservPeriod) reservation 293 | avUnits = difference units qMax 294 | isSubset = isSubsetOf (reservUnits reservation) avUnits 295 | guard $ isSubset || not (isIncluded t interval) 296 | (lChild, bsl) <- goLeft node 297 | (rChild, bsr) <- goRight node 298 | let (lower, upper) = (getFrom interval, getTo interval) 299 | toL = (getTo . getInterval) lChild 300 | fromR = (getFrom . getInterval) rChild 301 | lAnswer <- 302 | if lower >= fromR 303 | then Just [] 304 | else checkAvailability reservation units (lChild, bsl) 305 | rAnswer <- 306 | if upper <= toL 307 | then Just [] 308 | else checkAvailability reservation units (rChild, bsr) 309 | return $ lAnswer ++ rAnswer 310 | -------------------------------------------------------------------------------- /src/Time/SCalendar/Operations.hs: -------------------------------------------------------------------------------- 1 | module Time.SCalendar.Operations 2 | ( augmentCalendar 3 | , isQuantityAvailable 4 | , isReservAvailable 5 | , reservePeriod' 6 | , reservePeriod 7 | , reserveManyPeriods 8 | , reserveManyPeriods' 9 | , cancelPeriod 10 | , cancelManyPeriods 11 | , periodReport 12 | ) where 13 | 14 | 15 | import Data.Maybe (isNothing) 16 | import Time.SCalendar.Zippers 17 | import Time.SCalendar.Types 18 | import Data.Time (UTCTime(..), toGregorian) 19 | import Control.Monad (guard) 20 | import Time.SCalendar.Internal 21 | import qualified Data.Set as S ( null 22 | , size 23 | , difference 24 | , isSubsetOf 25 | , union 26 | , unions ) 27 | 28 | -- | Given an SCalendar of size 2^n, this function increases its size k times, that is, 29 | -- 2^(n+k). The new SCalendar is properly updated up to its root so that it will render 30 | -- the same results as the previous one. For example, given an SCalendar `c` of size 2^5=32, 31 | -- 'augmentCalendar c 3' would produce a new SCalendar of size 2^(5+3)=256. 32 | augmentCalendar :: SCalendar -- ^ SCalendar to be augmented. 33 | -> Int -- ^ Number of times by which the SCalendar will be augmented. 34 | -> Maybe SCalendar 35 | augmentCalendar _ k 36 | | k <= 0 = Nothing 37 | augmentCalendar scal k = do 38 | let interval = getInterval $ calendar scal 39 | (from, to) = (getFrom interval, getTo interval) 40 | (UTCTime gregDay _) = from 41 | (year, month, day) = toGregorian gregDay 42 | newSize = daysBetween from to * (2^k) 43 | largerCal <- createCalendar year month day newSize 44 | (_, bs) <- goToNode interval largerCal 45 | updatedCal <- updateQ (calendar scal, bs) 46 | (root, _) <- upToRoot updatedCal 47 | return $ SCalendar (calUnits scal) root 48 | 49 | -- | Given a quantity, this function determines if it is available in a TimePeriod for a 50 | -- specific SCalendar. Thus, it does not take into account the particular resources whose 51 | -- availability wants to be determined: it is only concerned with the availabilty of a quantity 52 | -- in a specific SCalendar. 53 | isQuantityAvailable :: Int -- ^ Quantity of resources. 54 | -> TimePeriod -- ^ TimePeriod over which we want to determine the availability of 55 | -- the quantity. 56 | -> SCalendar -- ^ SCalendar over which we want to determine the availability of 57 | -- the quantity in a Given TimePeriod. 58 | -> Bool 59 | isQuantityAvailable quant interval scal 60 | | S.null (calUnits scal) = False 61 | | quant <= 0 = False 62 | | quant > S.size (calUnits scal) = False 63 | | not $ intervalFitsCalendar interval (calendar scal) = False 64 | | otherwise = checkQuantAvailability (toTimeUnit interval) quant (calUnits scal) (calendar scal, []) 65 | 66 | -- | Given a Reservation, this function determines if it is available in a SCalendar. A 67 | -- Reservation is the product of a set of identifiers which point to reservable resources 68 | -- and a TimePeriod over which those resources are to be reserved. Thus, this function 69 | -- checks if that particular set of resources is available for a TimePeriod in the given SCalendar. 70 | isReservAvailable :: Reservation -> SCalendar -> Bool 71 | isReservAvailable reservation scal 72 | | S.null (calUnits scal) = False 73 | | not $ S.isSubsetOf (reservUnits reservation) (calUnits scal) = False 74 | | not $ intervalFitsCalendar (reservPeriod reservation) (calendar scal) = False 75 | | otherwise = checkReservAvailability reservation (calUnits scal) (calendar scal, []) 76 | 77 | -- | This function introduces a new Reservation in a Calendar. Note that since no availability check 78 | -- is performed before introducing the Reservation, here we use a plain Calendar. Thus this function 79 | -- is useful to introduce Reservations without any constraint, but that's why it must be used carefully 80 | -- since information can be lost due to the usage of the union set-operation to update the Q and QN sets 81 | -- in the Calendar. 82 | reservePeriod' :: Reservation -> Calendar -> Maybe Calendar 83 | reservePeriod' reservation calendar = do 84 | let interval = (toTimeUnit . reservPeriod) reservation 85 | tmNodes <- topMostNodes interval calendar 86 | let tmIntervals = fmap getZipInterval tmNodes 87 | updateCalendar tmIntervals (reservUnits reservation) calendar (\x y -> Just $ S.union x y) 88 | 89 | -- | This function is like reservePeriod' but adds a list of Reservations without any availabilty check. 90 | reserveManyPeriods' :: [Reservation] -> Calendar -> Maybe Calendar 91 | reserveManyPeriods' [] calendar = Just calendar 92 | reserveManyPeriods' (reservation:rs) calendar = do 93 | updatedCalendar <- addReservation reservation calendar 94 | reserveManyPeriods' rs updatedCalendar 95 | where 96 | addReservation res cal 97 | | isNothing maybeCalendar = Just cal 98 | | otherwise = maybeCalendar 99 | where maybeCalendar = reservePeriod' res cal 100 | 101 | -- | This function introduces a new Reservation in a SCalendar applying an availability check. This means 102 | -- that if the reservation conflicts with others already made in the SCalendar, it will no be introduced. 103 | -- Thus this function takes into account the set of reservable identifiers for the SCalendar to calculate 104 | -- the subset of available ones and introduce the Reservation if possible. 105 | reservePeriod :: Reservation -> SCalendar -> Maybe SCalendar 106 | reservePeriod reservation scalendar 107 | | not $ isReservAvailable reservation scalendar = Nothing 108 | reservePeriod reservation scal = do 109 | updatedCalendar <- reservePeriod' reservation (calendar scal) 110 | return $ SCalendar (calUnits scal) updatedCalendar 111 | 112 | -- | This function is like reservePeriod but introduces several Reservations at once. It is important to note 113 | -- that if a Reservation in the list conflicts with others already made in the SCalendar, it will be excluded. 114 | -- Thus the order of the Reservations in the list matters, since if one Reservation passes the availability check 115 | -- but the next one does not, then latter will be excluded. 116 | reserveManyPeriods :: [Reservation] -> SCalendar -> Maybe SCalendar 117 | reserveManyPeriods [] calendar = Just calendar 118 | reserveManyPeriods (reservation:rs) calendar = do 119 | updatedCalendar <- addReservation reservation calendar 120 | reserveManyPeriods rs updatedCalendar 121 | where 122 | addReservation res uCal 123 | | isNothing maybeCalendar = Just uCal 124 | | otherwise = maybeCalendar 125 | where maybeCalendar = reservePeriod res uCal 126 | 127 | -- | This function removes reserved identifiers in a Calendar according to the Set of identifiers and TimePeriod 128 | -- specified in the Cancellation. Thus a Cancellation only affects the nodes whose upper or lower bounds are 129 | -- included in the TimePeriod of the Cancellation. 130 | cancelPeriod :: Cancellation -> Calendar -> Maybe Calendar 131 | cancelPeriod cancellation calendar = do 132 | tmNodes <- topMostNodes (cancPeriod cancellation) calendar 133 | let tmIntervals = fmap getZipInterval tmNodes 134 | updateCalendar tmIntervals (cancUnits cancellation) calendar diff 135 | where 136 | diff x y 137 | | not $ S.isSubsetOf y x = Nothing 138 | | otherwise = Just (S.difference x y) 139 | 140 | -- | This is like cancelPeriod but performs several Cancellations at once. 141 | cancelManyPeriods :: [Cancellation] -> Calendar -> Maybe Calendar 142 | cancelManyPeriods [] calendar = Just calendar 143 | cancelManyPeriods (cancellation:cs) calendar = do 144 | updatedCalendar <- addCancellation cancellation calendar 145 | cancelManyPeriods cs updatedCalendar 146 | where 147 | addCancellation canc cal 148 | | isNothing maybeCalendar = Just cal 149 | | otherwise = maybeCalendar 150 | where maybeCalendar = cancelPeriod canc cal 151 | 152 | -- | Given a TimePeriod and a SCalendar, this function returns a Report which summarizes important 153 | -- data about the reserved and available identifiers in that SCalendar. 154 | periodReport :: TimePeriod -> SCalendar -> Maybe Report 155 | periodReport interval scal = do 156 | guard $ intervalFitsCalendar interval (calendar scal) 157 | tmNodes <- topMostNodes (toTimeUnit interval) (calendar scal) 158 | qMaxs <- mapM getQMax tmNodes 159 | let sQMax = S.unions qMaxs 160 | return $ Report interval (calUnits scal) sQMax (S.difference (calUnits scal) sQMax) 161 | -------------------------------------------------------------------------------- /src/Time/SCalendar/Types.hs: -------------------------------------------------------------------------------- 1 | module Time.SCalendar.Types 2 | ( TimePeriod(..) 3 | , Reservation(..) 4 | , Cancellation(..) 5 | , SCalendar(..) 6 | , Calendar(..) 7 | , Report(..) 8 | , isIncluded 9 | , getFrom 10 | , getTo 11 | , toTimeUnit 12 | , makeTimePeriod 13 | , makeReservation 14 | , makeCancellation 15 | , createCalendar 16 | , createSCalendar 17 | , oneDay 18 | , powerOfTwo 19 | ) where 20 | 21 | 22 | import Data.Time ( UTCTime(..) 23 | , NominalDiffTime 24 | , addUTCTime 25 | , fromGregorianValid ) 26 | import Data.Text (Text) 27 | import Data.Set (Set) 28 | import qualified Data.Set as S (empty) 29 | 30 | 31 | -- | This data type is either a TimeInterval of the form (start-date, end-date) 32 | -- or a TimeUnit which, in this case, is a nominal day. The time unit of this calendar 33 | -- library is a nominal day, that is, 86400 seconds. TimeIntervals as well as 34 | -- TimeUnits are stored as UTCTime so that it is easy to transform results to local 35 | -- time or store results in databases as timestamps. 36 | data TimePeriod = 37 | TimeInterval UTCTime UTCTime -- ^ TimeIntervals represent the number of days that a node 38 | -- in a calendar covers from a start-date up to an end-date. 39 | | TimeUnit UTCTime -- ^ TimeUnits are only encountered in the leaves of a calendar and represent 40 | -- a specific day of the calendar. 41 | deriving (Eq, Show) 42 | 43 | -- | Check if a time-period `t1` is included in a time-period `t2`. Note that neither a 44 | -- TimeUnit can be included in another TimeUnit nor a TimeInterval can be included 45 | -- in a TimeUnit. If two TimeIntervals are equal they are said to be included in 46 | -- one another. 47 | isIncluded :: TimePeriod -> TimePeriod -> Bool 48 | isIncluded (TimeUnit _) (TimeUnit _) = False 49 | isIncluded (TimeUnit t) (TimeInterval from to) = from <= t && t <= to 50 | isIncluded (TimeInterval _ _) (TimeUnit _) = False 51 | isIncluded (TimeInterval ifrom ito) (TimeInterval ofrom oto) 52 | = and [ ofrom <= ifrom, ifrom <= oto, ofrom <= ito, ito <= oto, ifrom <= ito ] 53 | 54 | -- | Getter function to get the UTCTime start-date from a TimePeriod. For a TimeUnit 55 | -- the start-sate and the end-date are equal. 56 | getFrom :: TimePeriod -> UTCTime 57 | getFrom (TimeUnit t) = t 58 | getFrom (TimeInterval from _) = from 59 | 60 | -- | Getter function to fet the UTCTime end-date from a TimePeriod. Again, for a TimeUnit 61 | -- the start-sate and the end-date are equal. 62 | getTo :: TimePeriod -> UTCTime 63 | getTo (TimeUnit t) = t 64 | getTo (TimeInterval _ to) = to 65 | 66 | -- | This function transforms a TimeInterval into a TimeUnit in case that the start-date and 67 | -- end-date of that TimeInterval are equal. 68 | toTimeUnit :: TimePeriod -> TimePeriod 69 | toTimeUnit i@(TimeUnit _) = i 70 | toTimeUnit i@(TimeInterval t1 t2) 71 | | t1 == t2 = TimeUnit t1 72 | | otherwise = i 73 | 74 | -- | A Reservation is the product of a set of identifiers and a TimePeriod over which the 75 | -- resources identified by the set will be reserved. 76 | data Reservation = Reservation 77 | { reservUnits :: Set Text -- ^ Set of identifiers which point to reservable resources. 78 | , reservPeriod :: TimePeriod -- ^ TimePeriod over which the resources will be reserved. 79 | } deriving (Eq, Show) 80 | 81 | -- | A Cancellation is the product of a set of identifiers which point to resources previously 82 | -- reserved in a Calendar and a TimePeriod over which those resources were reserved. 83 | data Cancellation = Cancellation 84 | { cancUnits :: Set Text -- ^ Set of identifiers which point to resources to be cancelled. 85 | , cancPeriod :: TimePeriod -- ^ TimePeriod over which the resources will be cancelled. 86 | } deriving (Eq, Show) 87 | 88 | -- | A Report represents a summary of important facts related to an SCalendar. 89 | data Report = Report 90 | { reportPeriod :: TimePeriod -- ^ The TimePeriod which the report covers. 91 | , totalUnits :: Set Text -- ^ The set of total identifiers reservable in the SCalendar this Report belongs to. 92 | , reservedUnits :: Set Text -- ^ The set of total identifiers which have been reserved in a TimePeriod in 93 | -- the SCalendar related to this Report. 94 | , remainingUnits :: Set Text -- ^ The set of total identifiers which are still available in a Time 104 | data Calendar = 105 | Unit TimePeriod (Set Text) (Set Text) 106 | | Node TimePeriod (Set Text) (Set Text) Calendar Calendar 107 | deriving (Eq, Show) 108 | 109 | -- | An SCalendar is the product of a set of identifiers, which point to a set of available resources, 110 | -- and a Calendar. 111 | data SCalendar = SCalendar 112 | { calUnits :: Set Text -- ^ Set of resources which can be reserved for the TimePeriod covered by 113 | -- the root node of the Calendar. 114 | , calendar :: Calendar -- ^ Calendar which covers the complete period of time over which a set of 115 | -- resources can be reserved. 116 | } deriving (Eq, Show) 117 | 118 | 119 | -- | Given a year, a month and a day this function creates a time period which covers the specified 120 | -- number of days. 121 | makeTimePeriod :: Integer -- ^ Year. 122 | -> Int -- ^ Month. 123 | -> Int -- ^ Day. 124 | -> Int -- ^ Number of days covered by TimePeriod. 125 | -> Maybe TimePeriod 126 | makeTimePeriod _ _ _ numDays 127 | | numDays < 0 = Nothing 128 | makeTimePeriod year month day numDays = do 129 | gregDay <- fromGregorianValid year month day 130 | let from = UTCTime gregDay 0 131 | to = (fromIntegral numDays * oneDay) `addUTCTime` from 132 | return $ if numDays == 0 133 | then TimeUnit from 134 | else TimeInterval from to 135 | 136 | -- | Given a TimePeriod and a set of identifiers this function creates a reservation. 137 | makeReservation :: TimePeriod -- ^ TimePeriod which the rerservation will cover. 138 | -> Set Text -- ^ Set of identifiers which point to the resources to be reserved from an SCalendar. 139 | -> Maybe Reservation 140 | makeReservation period units 141 | | null units = Nothing 142 | | not $ isValidInterval period' = Nothing 143 | | otherwise = Just $ Reservation units period' 144 | where 145 | period' = toTimeUnit period 146 | 147 | -- | Given a TimePeriod and a set of identifiers this function creates a cancellation. 148 | makeCancellation :: TimePeriod -- ^ TimePeriod which the cancellation will cover. 149 | -> Set Text -- ^ Set of identifiers which point to the resources to be cancelled from an SCalendar. 150 | -> Maybe Cancellation 151 | makeCancellation period units 152 | | null units = Nothing 153 | | not $ isValidInterval period' = Nothing 154 | | otherwise = Just $ Cancellation units period' 155 | where 156 | period' = toTimeUnit period 157 | 158 | -- | Given a year, a month, and a day this function creates a Calendar which covers the specified 159 | -- number of days. The TimePeriod in the root node of a Calendar does not exactly span the 160 | -- number of days specified in the function, but a number of days which is a power of 2 and 161 | -- which is greater than or equal to the number of days specified. 162 | createCalendar :: Integer -- ^ Year. 163 | -> Int -- ^ Month. 164 | -> Int -- ^ Day. 165 | -> Int -- ^ Number of days covered by the Calendar. 166 | -> Maybe Calendar 167 | createCalendar year month day numDays 168 | | numDays <= 1 = Nothing 169 | | otherwise = do 170 | gregDay <- fromGregorianValid year month day 171 | let fstDay = UTCTime gregDay 0 172 | return $ go fstDay power 173 | where 174 | power = powerOfTwo numDays 175 | go from factor 176 | | parentDist == 0 = Unit (TimeUnit from) S.empty S.empty 177 | | otherwise = 178 | Node (TimeInterval from ((oneDay * parentDist) `addUTCTime` from)) 179 | S.empty 180 | S.empty 181 | (go from (factor - 1)) 182 | (go ((oneDay * childDist) `addUTCTime` from) (factor - 1)) 183 | where 184 | parentDist = (2^factor) - 1 185 | childDist = 2^(factor - 1) 186 | 187 | -- | This constructor additionally attaches a set of identifiers, which point to the available resources of the 188 | -- calendar. Thus, this function creates an SCalendar which is basically a Calendar with a set of resources which 189 | -- can be reserved over the period of time determined by the root node of the Calendar. 190 | createSCalendar :: Integer -- ^ Year. 191 | -> Int -- ^ Month. 192 | -> Int -- ^ Day. 193 | -> Int -- ^ Number of days covered by the Calendar. 194 | -> Set Text -- ^ Set of resources which can be reserved for the TimePeriod covered by 195 | -- the root node of the Calendar. 196 | -> Maybe SCalendar 197 | createSCalendar _ _ _ _ tUnits 198 | | null tUnits = Nothing 199 | createSCalendar year month day numDays tUnits = do 200 | calendar <- createCalendar year month day numDays 201 | return $ SCalendar tUnits calendar 202 | 203 | 204 | -- HELPER FUNCTIONS 205 | isValidInterval :: TimePeriod -> Bool 206 | isValidInterval (TimeUnit _) = True 207 | isValidInterval (TimeInterval from to) = from < to 208 | 209 | powerOfTwo :: Int -> Int 210 | powerOfTwo n = 211 | let power = ceiling $ logBase 2 (fromIntegral $ abs n) 212 | in if power > 1 then power else 2 213 | 214 | oneDay :: NominalDiffTime 215 | oneDay = 86400 216 | -------------------------------------------------------------------------------- /src/Time/SCalendar/Zippers.hs: -------------------------------------------------------------------------------- 1 | module Time.SCalendar.Zippers 2 | ( CalendarZipper 3 | , goUp 4 | , goLeft 5 | , goRight 6 | , upToRoot 7 | , toZipper 8 | ) where 9 | 10 | 11 | import Data.Set (Set) 12 | import Data.Text (Text) 13 | import Time.SCalendar.Types (Calendar(..), TimePeriod) 14 | 15 | 16 | data Crumb = LeftCrumb TimePeriod (Set Text) (Set Text) Calendar 17 | | RightCrumb TimePeriod (Set Text) (Set Text) Calendar 18 | deriving Eq 19 | 20 | instance Show Crumb where 21 | show LeftCrumb{} = "LeftCrumb" 22 | show RightCrumb{} = "RightCrumb" 23 | 24 | type Breadcrumbs = [Crumb] 25 | type CalendarZipper = (Calendar, Breadcrumbs) 26 | 27 | 28 | goLeft :: CalendarZipper -> Maybe CalendarZipper 29 | goLeft (Node interval q qn left right, bs) = 30 | Just (left, LeftCrumb interval q qn right : bs) 31 | goLeft (Unit{}, _) = Nothing 32 | 33 | goRight :: CalendarZipper -> Maybe CalendarZipper 34 | goRight (Node interval q qn left right, bs) = 35 | Just (right, RightCrumb interval q qn left : bs) 36 | goRight (Unit{}, _) = Nothing 37 | 38 | goUp :: CalendarZipper -> Maybe CalendarZipper 39 | goUp (calendar, LeftCrumb interval q qn right : bs) 40 | = Just (Node interval q qn calendar right, bs) 41 | goUp (calendar, RightCrumb interval q qn left : bs) 42 | = Just (Node interval q qn left calendar, bs) 43 | goUp (_, []) = Nothing 44 | 45 | upToRoot :: CalendarZipper -> Maybe CalendarZipper 46 | upToRoot (node, []) = Just (node, []) 47 | upToRoot zipper = do 48 | parent <- goUp zipper 49 | upToRoot parent 50 | 51 | toZipper :: Calendar -> CalendarZipper 52 | toZipper calendar = (calendar, []) 53 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-9.0 2 | packages: 3 | - '.' 4 | -------------------------------------------------------------------------------- /test/SCalendarTest/Arbitrary.hs: -------------------------------------------------------------------------------- 1 | module SCalendarTest.Arbitrary where 2 | 3 | 4 | import Test.QuickCheck.Arbitrary 5 | import SCalendarTest.Helpers (testIdentifiers, startDay) 6 | import Control.Monad (replicateM, guard) 7 | import Data.Set (Set) 8 | import Data.Maybe (fromMaybe, fromJust) 9 | import Data.Text (Text) 10 | import qualified Data.Set as S (fromList) 11 | import Time.SCalendar.Types ( Calendar(..) 12 | , Reservation 13 | , TimePeriod 14 | , createCalendar 15 | , makeTimePeriod 16 | , makeReservation 17 | , getFrom 18 | , getTo ) 19 | import Time.SCalendar.Zippers ( CalendarZipper 20 | , goRight 21 | , goLeft ) 22 | import Time.SCalendar.Internal ( getZipInterval 23 | , getInterval 24 | , daysBetween 25 | , intervalFitsCalendar ) 26 | import Test.QuickCheck.Gen (choose, sized, vectorOf) 27 | 28 | 29 | -- | Convinient type for Intervals which fit a Calendar 30 | data CalendarReservations = CalReservs Calendar [Reservation] 31 | 32 | newtype Identifier = Identifier Text 33 | deriving (Eq, Ord) 34 | 35 | newtype Identifiers = Identifiers (Set Identifier) 36 | 37 | data RandomZippers = RandomZippers CalendarZipper CalendarZipper 38 | 39 | 40 | -- | Arbitrary-size calendars 41 | instance Arbitrary Calendar where 42 | arbitrary = do 43 | let (year, month, day) = startDay 44 | -- ^ Random size calendars up to 512 days 45 | -- and starting from 1970 46 | size <- choose (2, 9) 47 | return $ fromJust $ createCalendar year month day size 48 | 49 | -- | Arbitrary instance for time Intervals 50 | instance Arbitrary TimePeriod where 51 | arbitrary = do 52 | numDays <- choose (1, 27) 53 | return $ fromJust $ makeTimePeriod 1970 1 1 numDays 54 | -- | -- 55 | 56 | 57 | -- | Arbitrary instance for a single Identifier 58 | instance Arbitrary Identifier where 59 | arbitrary = do 60 | i <- choose (0, 99) 61 | return $ Identifier $ testIdentifiers !! i 62 | 63 | instance Show Identifier where 64 | show (Identifier i) = show i 65 | -- | -- 66 | 67 | 68 | -- | Arbitrary instance for CalendarReservations 69 | instance Arbitrary CalendarReservations where 70 | arbitrary = do 71 | calendar <- arbitrary 72 | n <- choose (1, 50) 73 | reservs <- replicateM n $ getSuitableInterval calendar 74 | return $ CalReservs calendar reservs 75 | where 76 | buildReserv interval = sized $ \n -> do 77 | k <- choose (1, abs $ n + 1) 78 | identifiers <- vectorOf k arbitrary 79 | return $ fromJust $ makeReservation interval (S.fromList $ (\(Identifier t) -> t) <$> identifiers) 80 | -- ^ -- 81 | getSuitableInterval cal = do 82 | interval <- arbitrary 83 | maybe (getSuitableInterval cal) 84 | (const $ buildReserv interval) 85 | (guard $ intervalFitsCalendar interval cal) 86 | 87 | instance Show CalendarReservations where 88 | show (CalReservs calendar reservs) = 89 | "Calendar root: " ++ show (getInterval calendar) ++ 90 | " , " ++ 91 | "Reservations: " ++ show reservs 92 | -- | -- 93 | 94 | 95 | -- | Arbitrary pair of Zippers belonging to the same calendar 96 | instance Arbitrary RandomZippers where 97 | arbitrary = do 98 | calendar <- arbitrary 99 | let depth = getDepth calendar 100 | zip1Depth <- choose (0, depth) 101 | zip2Depth <- choose (0, depth) 102 | let root = (calendar, []) 103 | maybeZippers = do 104 | zip1 <- goDown (Just root) zip1Depth 105 | zip2 <- goDown (Just root) zip2Depth 106 | return $ RandomZippers zip1 zip2 107 | return $ fromMaybe (RandomZippers root root) maybeZippers 108 | where 109 | getDepth :: Calendar -> Int 110 | getDepth cal = round $ 111 | let interval = getInterval cal 112 | in logBase 2 (fromIntegral $ daysBetween (getFrom interval) (getTo interval)) 113 | -- ^ -- 114 | pickBranch zipper n 115 | | n `mod` 2 == 0 = goRight zipper 116 | | otherwise = goLeft zipper 117 | -- ^ -- 118 | goDown maybeZipper 0 = maybeZipper 119 | goDown maybeZipper i = 120 | maybeZipper >>= (\zipper -> goDown (pickBranch zipper i) (i-1)) 121 | 122 | instance Show RandomZippers where 123 | show (RandomZippers zip1 zip2) = show (getZipInterval zip1, getZipInterval zip2) 124 | -------------------------------------------------------------------------------- /test/SCalendarTest/Constructors.hs: -------------------------------------------------------------------------------- 1 | module SCalendarTest.Constructors where 2 | 3 | 4 | import Time.SCalendar.Operations (augmentCalendar) 5 | import SCalendarTest.Helpers (startDay) 6 | import Data.Maybe (fromMaybe) 7 | import Time.SCalendar.Internal ( daysBetween 8 | , getInterval ) 9 | import Time.SCalendar.Types ( SCalendar(..) 10 | , powerOfTwo 11 | , createCalendar 12 | , getFrom 13 | , getTo ) 14 | import qualified Data.Set as S (empty) 15 | 16 | 17 | calendarSizePowerOfTwo :: Int -> Bool 18 | calendarSizePowerOfTwo n = fromMaybe False $ do 19 | let (year, month, day) = startDay 20 | size = if n > 1 then n else abs n + 2 21 | calendar <- createCalendar year month day size 22 | let i = getInterval calendar 23 | return $ daysBetween (getFrom i) (getTo i) == 2 ^ powerOfTwo size 24 | 25 | augmentedCalendarPowerOfKPlusN :: Int -> Int -> Bool 26 | augmentedCalendarPowerOfKPlusN n k = fromMaybe False $ do 27 | let (year, month, day) = startDay 28 | n' = powerOfTwo n 29 | k' = powerOfTwo k 30 | calendar <- createCalendar year month day n' 31 | (SCalendar _ calendar') <- augmentCalendar (SCalendar S.empty calendar) k' 32 | let i = getInterval calendar 33 | j = getInterval calendar' 34 | return $ daysBetween (getFrom j) (getTo j) == daysBetween (getFrom i) (getTo i) * (2 ^ k') 35 | -------------------------------------------------------------------------------- /test/SCalendarTest/Helpers.hs: -------------------------------------------------------------------------------- 1 | module SCalendarTest.Helpers 2 | ( getUTCdayNum 3 | , testIdentifiers 4 | , startDay 5 | ) where 6 | 7 | 8 | import Data.Time.Clock (UTCTime (..)) 9 | import Data.Time.Calendar (toGregorian) 10 | import Data.Text (Text) 11 | import qualified Data.Text as T (pack) 12 | 13 | 14 | testIdentifiers :: [Text] 15 | testIdentifiers = T.pack <$> (show <$> [1.. 100]) 16 | 17 | getUTCdayNum :: UTCTime -> Int 18 | getUTCdayNum (UTCTime day _) = 19 | let (_, _, num) = toGregorian day 20 | in num 21 | 22 | startDay :: (Integer, Int, Int) 23 | startDay = (1970, 1, 1) 24 | -------------------------------------------------------------------------------- /test/SCalendarTest/Internal.hs: -------------------------------------------------------------------------------- 1 | module SCalendarTest.Internal where 2 | 3 | 4 | import Data.List (elem) 5 | import Data.Maybe (isJust, fromMaybe) 6 | import Data.Time (UTCTime(..), toGregorian, diffUTCTime ) 7 | import SCalendarTest.Helpers (getUTCdayNum) 8 | import Time.SCalendar.Types ( Calendar(..) 9 | , Reservation(..) 10 | , TimePeriod 11 | , getFrom 12 | , getTo 13 | , isIncluded 14 | , powerOfTwo 15 | , oneDay 16 | , makeTimePeriod ) 17 | import Time.SCalendar.Zippers (goUp) 18 | import SCalendarTest.Arbitrary (RandomZippers(..), CalendarReservations(..)) 19 | import Time.SCalendar.Internal ( goToNode 20 | , leftMostTopNode 21 | , rightMostTopNode 22 | , topMostNodes 23 | , getZipInterval 24 | , commonParent ) 25 | 26 | 27 | alwaysGreateOrEqualThanN :: Int -> Bool 28 | alwaysGreateOrEqualThanN n = 2^ powerOfTwo n >= n 29 | 30 | eqIntervalsIfIncludeEachOther :: TimePeriod -> TimePeriod -> Bool 31 | eqIntervalsIfIncludeEachOther i j 32 | | isIncluded i j && isIncluded j i = i1 == j1 && i2 == j2 33 | | isIncluded i j = not $ isIncluded j i 34 | | isIncluded j i = not $ isIncluded i j 35 | | not (isIncluded i j) && not (isIncluded j i) && wellFormed = i1 < j2 || j1 < i2 36 | | otherwise = not wellFormed 37 | where 38 | (i1, i2) = (getFrom i, getTo i) 39 | (j1, j2) = (getFrom j, getTo j) 40 | wellFormed = i1 <= i2 && j1 <= j2 41 | 42 | returnsTargetZipper :: Calendar -> TimePeriod -> Bool 43 | returnsTargetZipper calendar interval = 44 | let maybeCalendar = fst <$> goToNode interval calendar 45 | in maybe (ifNothing calendar) checkTarget maybeCalendar 46 | where 47 | checkTarget (Unit unit _ _) = unit == interval 48 | checkTarget (Node interval' _ _ _ _) = interval' == interval 49 | -- ^ -- 50 | ifNothing (Node interval' _ _ _ _) = 51 | not $ isIncluded interval interval' && ((getUTCdayNum . getFrom) interval) `mod` 2 == 0 52 | ifNothing _ = False 53 | 54 | isLeftMostTopNode :: CalendarReservations -> Bool 55 | isLeftMostTopNode (CalReservs _ []) = False 56 | isLeftMostTopNode (CalReservs calendar (reserv:_)) = fromMaybe False $ do 57 | i2 <- getZipInterval <$> leftMostTopNode i1 calendar 58 | return $ getFrom i2 == getFrom i1 && 59 | if getTo i2 == getTo i1 60 | then (getFrom i1, getTo i1) == (getFrom i2, getTo i2) 61 | else getTo i2 < getTo i1 62 | where 63 | i1 = reservPeriod reserv 64 | 65 | isRightMostTopNode :: CalendarReservations -> Bool 66 | isRightMostTopNode (CalReservs _ []) = False 67 | isRightMostTopNode (CalReservs calendar (reserv:_)) = fromMaybe False $ do 68 | i2 <- getZipInterval <$> rightMostTopNode i1 calendar 69 | return $ getTo i2 == getTo i1 && 70 | if getFrom i2 == getFrom i1 71 | then (getFrom i1, getTo i1) == (getFrom i2, getTo i2) 72 | else getFrom i2 > getFrom i1 73 | where 74 | i1 = reservPeriod reserv 75 | 76 | returnsCommonParent :: RandomZippers -> Bool 77 | returnsCommonParent (RandomZippers zip1 zip2) = fromMaybe False $ do 78 | parent <- commonParent zip1 zip2 79 | let c1 = getZipInterval zip1 80 | c2 = getZipInterval zip2 81 | p= getZipInterval parent 82 | return $ getFrom p <= getFrom c1 && 83 | getFrom p <= getFrom c2 && 84 | getTo p >= getTo c1 && 85 | getTo p >= getTo c2 86 | 87 | leftMostAndRightMostInTopMost :: CalendarReservations -> Bool 88 | leftMostAndRightMostInTopMost (CalReservs _ []) = False 89 | leftMostAndRightMostInTopMost (CalReservs calendar (reserv:_)) = fromMaybe False $ do 90 | ltmInterval <- getZipInterval <$> leftMostTopNode interval calendar 91 | rtmInterval <- getZipInterval <$> rightMostTopNode interval calendar 92 | topMostIntervals <- (fmap . fmap) getZipInterval (topMostNodes interval calendar) 93 | return $ (ltmInterval `elem` topMostIntervals) && (rtmInterval `elem` topMostIntervals) 94 | where 95 | interval = reservPeriod reserv 96 | 97 | outerMostNodesIncludeIntermediate :: CalendarReservations -> Bool 98 | outerMostNodesIncludeIntermediate (CalReservs _ []) = False 99 | outerMostNodesIncludeIntermediate (CalReservs calendar (reserv:_)) = fromMaybe False $ do 100 | from' <- (getFrom . getZipInterval) <$> leftMostTopNode interval calendar 101 | to' <- (getTo . getZipInterval) <$> rightMostTopNode interval calendar 102 | topMostIntervals <- (fmap . fmap) getZipInterval (topMostNodes interval calendar) 103 | -- ^ Each intermediate interval must be included in the leftmost and rightmost ones 104 | let numDays = round $ diffUTCTime to' from' / oneDay 105 | (UTCTime gregDay _) = from' 106 | (year, month, day) = toGregorian gregDay 107 | timePeriod <- makeTimePeriod year month day numDays 108 | return $ all (`isIncluded` timePeriod) topMostIntervals || timePeriod `elem` topMostIntervals 109 | where 110 | interval = reservPeriod reserv 111 | 112 | ifOnlyOneTopNodeItEqualsInterval :: CalendarReservations -> Bool 113 | ifOnlyOneTopNodeItEqualsInterval (CalReservs _ []) = False 114 | ifOnlyOneTopNodeItEqualsInterval (CalReservs calendar (reserv:_)) = fromMaybe False $ do 115 | topMostIntervals <- (fmap . fmap) getZipInterval (topMostNodes interval calendar) 116 | if length topMostIntervals == 1 117 | then return $ head topMostIntervals == interval 118 | else return True 119 | where 120 | interval = reservPeriod reserv 121 | 122 | parentOfTopNodesNotIncluded :: CalendarReservations -> Bool 123 | parentOfTopNodesNotIncluded (CalReservs _ []) = False 124 | parentOfTopNodesNotIncluded (CalReservs calendar (reserv:_)) = fromMaybe False $ do 125 | from' <- (getFrom . getZipInterval) <$> leftMostTopNode interval calendar 126 | to' <- (getTo . getZipInterval) <$> rightMostTopNode interval calendar 127 | tmNodes <- topMostNodes interval calendar 128 | parentIntervals <- (fmap . fmap) getZipInterval 129 | (sequence $ filter isJust (goUp <$> tmNodes)) 130 | let numDays = round $ diffUTCTime to' from' / oneDay 131 | (UTCTime gregDay _) = from' 132 | (year, month, day) = toGregorian gregDay 133 | timePeriod <- makeTimePeriod year month day numDays 134 | return $ all (`notIncluded` timePeriod) parentIntervals 135 | where 136 | notIncluded i1 i2 = not $ isIncluded i1 i2 137 | -- ^ -- 138 | interval = reservPeriod reserv 139 | -------------------------------------------------------------------------------- /test/SCalendarTest/Operations.hs: -------------------------------------------------------------------------------- 1 | module SCalendarTest.Operations where 2 | 3 | 4 | import Time.SCalendar.Operations ( reserveManyPeriods 5 | , reservePeriod' 6 | , cancelManyPeriods 7 | , isQuantityAvailable, 8 | isReservAvailable ) 9 | import SCalendarTest.Helpers (getUTCdayNum, testIdentifiers) 10 | import SCalendarTest.Arbitrary (CalendarReservations(..)) 11 | import Data.Maybe (isJust, fromMaybe) 12 | import Time.SCalendar.Internal ( goToNode 13 | , getQMax 14 | , getZipInterval ) 15 | import Time.SCalendar.Zippers (goLeft, goRight, goUp) 16 | import Time.SCalendar.Types ( Calendar(..) 17 | , SCalendar(..) 18 | , Reservation(..) 19 | , getFrom 20 | , getTo 21 | , makeCancellation ) 22 | import qualified Data.Set as S (isSubsetOf, fromList, size) 23 | 24 | 25 | symmetricalIntervalLength :: Calendar -> Bool 26 | symmetricalIntervalLength calendar = 27 | fromMaybe False (checkSimmetry calZipper) 28 | where 29 | calZipper = (calendar, []) 30 | -- ^ -- 31 | checkSimmetry (Unit{}, _) = Just True 32 | checkSimmetry zipper = do 33 | leftChild <- goLeft zipper 34 | rightChild <- goRight zipper 35 | let i1 = getZipInterval leftChild 36 | i2 = getZipInterval rightChild 37 | intervalSymmetry = getUTCdayNum (getTo i1) - getUTCdayNum (getFrom i1) 38 | == getUTCdayNum (getTo i2) - getUTCdayNum (getFrom i2) 39 | return $ intervalSymmetry && 40 | fromMaybe False (checkSimmetry leftChild) && 41 | fromMaybe False (checkSimmetry rightChild) 42 | 43 | qMaxOfParentIncludedInChildren :: CalendarReservations -> Bool 44 | qMaxOfParentIncludedInChildren (CalReservs calendar reservs) = fromMaybe False $ do 45 | (SCalendar _ calendar') <- reserveManyPeriods reservs (SCalendar (S.fromList testIdentifiers) calendar) 46 | checks <- sequence $ filter isJust (checkQmax calendar' . reservPeriod <$> reservs) 47 | return $ and checks 48 | where 49 | checkQmax cal interval = do 50 | zipper <- goToNode interval cal 51 | zipParent <- goUp zipper 52 | zipLChild <- goLeft zipper 53 | qMax <- getQMax zipper 54 | qMaxParent <- getQMax zipParent 55 | qMaxLChild <- getQMax zipLChild 56 | return $ qMaxParent `S.isSubsetOf` qMax && 57 | qMax `S.isSubsetOf` qMaxLChild 58 | 59 | quantityNotAvailableAfterReservation :: CalendarReservations -> Bool 60 | quantityNotAvailableAfterReservation (CalReservs _ []) = False 61 | quantityNotAvailableAfterReservation (CalReservs calendar (reserv:_)) = fromMaybe False $ do 62 | calendar' <- reservePeriod' reserv calendar 63 | return $ not $ 64 | isQuantityAvailable (totalUnits - S.size (reservUnits reserv) + 1) 65 | (reservPeriod reserv) 66 | (SCalendar (S.fromList testIdentifiers) calendar') 67 | where 68 | totalUnits = length testIdentifiers 69 | 70 | periodNotAvailableAfterReservation :: CalendarReservations -> Bool 71 | periodNotAvailableAfterReservation (CalReservs _ []) = False 72 | periodNotAvailableAfterReservation (CalReservs calendar (reserv:_)) = fromMaybe False $ do 73 | calendar' <- reservePeriod' reserv calendar 74 | return $ not $ 75 | isReservAvailable reserv (SCalendar (S.fromList testIdentifiers) calendar') && 76 | S.size (reservUnits reserv) > 0 77 | 78 | reservAvailableAfterCancellation :: CalendarReservations -> Bool 79 | reservAvailableAfterCancellation (CalReservs _ []) = False 80 | reservAvailableAfterCancellation (CalReservs calendar reservs) = fromMaybe False $ do 81 | (SCalendar _ calendar') <- reserveManyPeriods reservs 82 | (SCalendar (S.fromList testIdentifiers) calendar) 83 | cancellations <- mapM reservToCanc reservs 84 | calendar'' <- cancelManyPeriods cancellations calendar' 85 | return $ and $ 86 | flip isReservAvailable (SCalendar (S.fromList testIdentifiers) calendar'') <$> reservs 87 | where 88 | reservToCanc reserv = makeCancellation (reservPeriod reserv) (reservUnits reserv) 89 | -------------------------------------------------------------------------------- /test/Test.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | 4 | import Test.Hspec 5 | import Test.QuickCheck.Property (property) 6 | import SCalendarTest.Internal ( alwaysGreateOrEqualThanN 7 | , eqIntervalsIfIncludeEachOther 8 | , returnsTargetZipper 9 | , isLeftMostTopNode 10 | , isRightMostTopNode 11 | , returnsCommonParent 12 | , leftMostAndRightMostInTopMost 13 | , outerMostNodesIncludeIntermediate 14 | , ifOnlyOneTopNodeItEqualsInterval 15 | , parentOfTopNodesNotIncluded ) 16 | import SCalendarTest.Operations ( symmetricalIntervalLength 17 | , qMaxOfParentIncludedInChildren 18 | , quantityNotAvailableAfterReservation 19 | , periodNotAvailableAfterReservation 20 | , reservAvailableAfterCancellation ) 21 | import SCalendarTest.Constructors (calendarSizePowerOfTwo, augmentedCalendarPowerOfKPlusN) 22 | 23 | 24 | main :: IO () 25 | main = 26 | hspec $ do 27 | describe "powerOftwo :: Int -> Int" $ do 28 | it "always returns a power of 2 greater or equal than its argument" $ do 29 | property alwaysGreateOrEqualThanN 30 | describe "isIncluded :: isIncluded :: TimePeriod -> TimePeriod -> Bool" $ do 31 | it "determines if the first interval is included in the second one" $ do 32 | property eqIntervalsIfIncludeEachOther 33 | describe "createCalendar :: createCalendar :: FirstDay -> NumDays -> Maybe Calendar" $ do 34 | it "creates a calendar with a number of days 2^(powerOftwo NumDays)" $ do 35 | property calendarSizePowerOfTwo 36 | it "creates a calendar with symmetric intervals" $ do 37 | property symmetricalIntervalLength 38 | describe "augmentCalendar :: SCalendar -> Int -> Maybe SCalendar" $ do 39 | it "always creates a calendar augmented k times the power of the original size" $ do 40 | property augmentedCalendarPowerOfKPlusN 41 | describe "goToNode :: TimePeriod -> Calendar -> Maybe CalendarZipper" $ do 42 | it "goes to the node with interval (From, To) in the calendar" $ do 43 | property returnsTargetZipper 44 | describe "leftMostTopNode :: TimePeriod -> Calendar -> Maybe CalendarZipper" $ do 45 | it "returns a Zipper with a valid left-most interval" $ do 46 | property isLeftMostTopNode 47 | describe "rightMostTopNode :: TimePeriod -> Calendar -> Maybe CalendarZipper" $ do 48 | it "returns a Zipper with a valid right-most interval" $ do 49 | property isRightMostTopNode 50 | describe "commonParent :: CalendarZipper -> CalendarZipper -> Maybe CalendarZipper" $ do 51 | it "returns a Zipper which is a common parent node of its arguments" $ do 52 | property returnsCommonParent 53 | describe "topMostNodes :: TimePeriod -> Calendar -> Maybe [CalendarZipper]" $ do 54 | it "returns a list of topmost-nodes *including* the rightmost and the leftmost ones" $ do 55 | property leftMostAndRightMostInTopMost 56 | it "returns a list of topmost-nodes *included* in the rightmost and the leftmost ones" $ do 57 | property outerMostNodesIncludeIntermediate 58 | it "returns a list of topmost-nodes with no parent included in (From, To)" $ do 59 | property parentOfTopNodesNotIncluded 60 | context "when there is only one topmost-node" $ do 61 | it "must return an interval equal to (From, To)" $ do 62 | property ifOnlyOneTopNodeItEqualsInterval 63 | describe "reserveManyPeriods :: [Reservation] -> SCalendar -> Maybe SCalendar" $ do 64 | it "returns a Calendar which satisfies that QMax of parent node is included in QMax of left child" $ do 65 | property qMaxOfParentIncludedInChildren 66 | describe "isQuantityAvailable :: Quantity -> TimePeriod -> SCalendar -> Bool" $ do 67 | it "determines if a quantity is available after a reservation" $ do 68 | property quantityNotAvailableAfterReservation 69 | describe "isReservAvailable :: Reservation -> SCalendar -> Bool" $ do 70 | context "when a node has already been reserved" $ do 71 | it "returns false for the same reservation in that node" $ do 72 | property periodNotAvailableAfterReservation 73 | describe "cancelManyPeriods :: [Cancellation] -> Calendar -> Maybe Calendar" $ do 74 | context "when a reservation in a node is cancelled" $ do 75 | it "becomes again availabale" $ do 76 | property reservAvailableAfterCancellation 77 | --------------------------------------------------------------------------------