diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/orchestrate.cabal b/orchestrate.cabal new file mode 100644 --- /dev/null +++ b/orchestrate.cabal @@ -0,0 +1,78 @@ +-- Initial orchestrate.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: orchestrate +version: 0.2.0.0 +synopsis: An API client for http://orchestrate.io/. +-- description: +license: Apache-2.0 +license-file: LICENSE +author: Eric Rochester +maintainer: erochest@gmail.com +-- copyright: +category: Database +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +flag network-specs + description: Include specs that hit the live network site. Needs to + be run with tests enabled to do anything. + default: False + +library + hs-source-dirs: src + exposed-modules: Database.Orchestrate + , Database.Orchestrate.Collection + , Database.Orchestrate.Events + , Database.Orchestrate.Graph + , Database.Orchestrate.KeyValue + , Database.Orchestrate.Network + , Database.Orchestrate.Ref + , Database.Orchestrate.Search + , Database.Orchestrate.Types + , Database.Orchestrate.Utils + -- other-modules: + -- other-extensions: + build-depends: base >=4.7 && <4.8 + , text + , wreq + , http-client + , http-types + , aeson + , unordered-containers + , errors + , either + , mtl + , lens + , data-default + , bytestring + , case-insensitive + , transformers + -- hs-source-dirs: + default-language: Haskell2010 + +test-suite orchestrate-specs + type: exitcode-stdio-1.0 + ghc-options: -threaded -rtsopts + hs-source-dirs: specs + main-is: Specs.hs + build-depends: base == 4.7.* + , orchestrate + , QuickCheck + , smallcheck + , hspec + , lens + , text + , aeson + , bytestring + , wreq + , errors + default-language: Haskell2010 + if flag(network-specs) + cpp-options: -DNETWORK_SPECS + +source-repository this + type: git + location: git://github.com/erochest/orchestrate.git + tag: 0.2.0.0 diff --git a/specs/Specs.hs b/specs/Specs.hs new file mode 100644 --- /dev/null +++ b/specs/Specs.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/src/Database/Orchestrate.hs b/src/Database/Orchestrate.hs new file mode 100644 --- /dev/null +++ b/src/Database/Orchestrate.hs @@ -0,0 +1,25 @@ + + +module Database.Orchestrate + ( module Database.Orchestrate.Collection + , module Database.Orchestrate.Events + , module Database.Orchestrate.Graph + , module Database.Orchestrate.KeyValue + , module Database.Orchestrate.Network + , module Database.Orchestrate.Ref + , module Database.Orchestrate.Search + , module Database.Orchestrate.Types + , module Database.Orchestrate.Utils + ) where + + +import qualified Database.Orchestrate.Collection +import qualified Database.Orchestrate.Events +import qualified Database.Orchestrate.Graph +import qualified Database.Orchestrate.KeyValue +import qualified Database.Orchestrate.Network +import qualified Database.Orchestrate.Ref +import qualified Database.Orchestrate.Search +import qualified Database.Orchestrate.Types +import qualified Database.Orchestrate.Utils + diff --git a/src/Database/Orchestrate/Collection.hs b/src/Database/Orchestrate/Collection.hs new file mode 100644 --- /dev/null +++ b/src/Database/Orchestrate/Collection.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} + + +{-| +This implements the to +manage collections on Orchestrate. +-} + +module Database.Orchestrate.Collection + ( deleteCollection + ) where + + +import Control.Monad +import qualified Data.Text as T +import Network.Wreq + +import Database.Orchestrate.Types +import Database.Orchestrate.Utils + + +-- | This deletes a collection. See +-- for +-- more information. +-- +-- > deleteCollection "collection-name" + +deleteCollection :: Collection -> OrchestrateIO () +deleteCollection c = + void $ apiCheck [] [c] ["force" := ("true" :: T.Text)] deleteWith diff --git a/src/Database/Orchestrate/Events.hs b/src/Database/Orchestrate/Events.hs new file mode 100644 --- /dev/null +++ b/src/Database/Orchestrate/Events.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +{- | +This module implements the for +working with Orchestrate events. +-} + + +module Database.Orchestrate.Events + ( + -- * API Functions + getEvent + , createEvent + , updateEvent + , deleteEvent + , listEvents + + -- * Location Conversion Functions + , locationEventItem + , eventItemLocation + ) where + + +import Control.Applicative +import Control.Lens +import Control.Monad +import Data.Aeson +import Data.Maybe +import Data.Monoid +import qualified Data.Text as T +import Network.Wreq + +import Database.Orchestrate.Types +import Database.Orchestrate.Utils + + +urlPath :: OrchestrateData a => a -> EventType -> Timestamp -> Int -> [T.Text] +urlPath a et ts o = [tableName a, dataKey a, "events", et, tshow ts, tshow o] + +-- | This retrieves a single event. See +-- for more information. +-- +-- For example, this retrieves a transaction event. +-- +-- > getEvent data "transaction" 784111777000 79 +getEvent :: (OrchestrateData a, FromJSON b) + => a -- ^ The data that the event is associated with. + -> EventType -- ^ The kind of event. + -> Timestamp -- ^ The event's timestamp. + -> Int -- ^ The event's ordinal number. + -> OrchestrateIO (Maybe (EventItem b a)) -- ^ 'Just' the event or 'Nothing'. +getEvent a etype ts o = + join . fmap (decode . (^.responseBody)) <$> api404 [] up [] getWith + where up = urlPath a etype ts o + +-- | This creates an event and returns its 'Location'. See +-- for more information. +-- +-- For example, this creates a transaction, using the current time for the +-- timestamp. +-- +-- > createEvent data "transaction" transactionData Nothing +createEvent :: (OrchestrateData a, ToJSON b) + => a -- ^ The data that the event is associated with. + -> EventType -- ^ The kind of event. + -> b -- ^ The event data. + -> Maybe Timestamp -- ^ The event's timestamp. If not given, the current time is used. + -> OrchestrateIO Location -- ^ Returns the event's location. +createEvent a eType e mts = + getLocation <$> api [] url [] (rot postWith (toJSON e)) + where url = [tableName a, dataKey a, "events", eType] + ++ maybeToList (fmap tshow mts) + +-- | This updates the data for an event. The storage is keyed by type, +-- timestamp, and ordinal, so the event data can change. See the +-- for more +-- information. +-- +-- For example: +-- +-- > updateEvent data "transaction" updatedTransactionData +-- > <$> loc ^? locationTimestamp +-- > <*> loc ^? locationOrdinal +updateEvent :: (OrchestrateData a, ToJSON b) + => a -- ^ The data that the event is associated with. + -> EventType -- ^ The kind of event. + -> b -- ^ The updated event data. + -> Timestamp -- ^ The timestamp for the event. + -> Int -- ^ The ordinal for the event. + -> IfMatch' -- ^ If given, will only succeed if the ref matches + -- the event's currently stored ref. + -> OrchestrateIO Location -- ^ Returns the 'Location' for the new event data. +updateEvent a eType e ts o m = + getLocation <$> api (ifMatch' m) up [] (rot putWith (toJSON e)) + where up = urlPath a eType ts o + +-- | This deletes an event. See the +-- for more information. +-- +-- For example: +-- +-- > deleteEvent data "transaction" +-- > <$> loc ^? locationTimestamp +-- > <*> loc ^? locationOrdinal +deleteEvent :: OrchestrateData a + => a -- ^ The data that the event is associated with. + -> EventType -- ^ The kind of event. + -> Timestamp -- ^ The timestamp for the event. + -> Int -- ^ The ordinal for the event. + -> IfMatch' -- ^ If given, will only succeed if the ref matches + -- the event's currently stored ref. + -> OrchestrateIO () +deleteEvent a eType ts o m = + void $ apiCheck (ifMatch' m) url ["purge" := ("true" :: T.Text)] deleteWith + where url = urlPath a eType ts o + +-- | This lists all the events within a given range for a data. See the +-- for more +-- information. +-- +-- For example: +-- +-- > listEvents data "transaction" (Just 25) (Open, Open) +listEvents :: (OrchestrateData a, FromJSON b) + => a -- ^ The data the events are to associated with. + -> EventType -- ^ The type of events to retrieve. + -> Maybe Int -- ^ The maximum number of event data to return. + -- The default is 10, and the maximum is 100. + -> Range (Timestamp, Maybe Int) -- ^ The range of events to retrieve. Each range + -- is the timestamp and maybe the ordinal. + -> OrchestrateIO (EventList b a) +listEvents a eType limit (start, end) = apiCheckDecode [] up ps getWith + where up = [tableName a, dataKey a, "events", eType] + ps = catMaybes [ ("limit" :=) <$> limit + , rangeStart "Event" $ fmap eventRange start + , rangeEnd "Event" $ fmap eventRange end + ] + eventRange (ts, mint) = tshow ts <> maybe mempty (("/" <>) . tshow) mint + +-- | This takes a 'Location' and an event datum and returns the 'EventItem' +-- representing it. +locationEventItem :: Location -> a -> Maybe (EventItem a b) +locationEventItem loc a = EventItem <$> resultItem a <*> timestamp <*> ordinal + where timestamp = loc ^? locationTimestamp + ordinal = loc ^? locationOrdinal + resultItem x = (`ResultItem` x) <$> ePath + ePath = EventPath + <$> path + <*> loc ^? locationType + <*> timestamp + <*> ordinal + path = Path + <$> loc ^? locationCollection + <*> loc ^? locationKey + <*> loc ^? locationRef + +-- | This takes an 'EventItem' and returns the datum and 'Location' +-- associated with that item. +eventItemLocation :: Monad m => EventItem a b -> OrchestrateT m (a, Location) +eventItemLocation ei = do + v <- view sessionVersion + let epath = ei ^. eventItem . itemPath + path = epath ^. eventPath + loc = T.intercalate "/" [ "" + , "v" <> tshow v + , path ^. itemCollection + , path ^. itemKey + , "events" + , epath ^. eventPathType + , tshow $ epath ^. eventPathTime + , tshow $ epath ^. eventPathOrd + ] + return (ei ^. eventItem . itemValue, loc) diff --git a/src/Database/Orchestrate/Graph.hs b/src/Database/Orchestrate/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Database/Orchestrate/Graph.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +This module implements the . +-} + +module Database.Orchestrate.Graph + ( getRel + , createRel + , deleteRel + ) where + + +import Control.Monad +import Data.Aeson +import qualified Data.Text as T +import Network.Wreq + +import Database.Orchestrate.Types +import Database.Orchestrate.Utils + + +-- | This retrieves a list of target nodes from edges originating from @a@. +-- For more information see . +-- +-- If the third parameter is not empty, it represents additional edges that +-- will be traversed to get to the target. +-- +-- For example: +-- +-- > getRel data "friend" ["last_name"] +getRel :: (OrchestrateData a, FromJSON b) + => a -- ^ The originating node. + -> RelKind -- ^ The first edge to traverse. + -> [RelKind] -- ^ Any additional edges to traverse. + -> OrchestrateIO (RelList a b) -- ^ A list of nodes originating from @a@. +getRel from rel rels = apiCheckDecode [] url [] getWith + where url = tableName from : dataKey from : "relations" : rel : rels + +-- | Creates a relationship (an edge) between two nodes. The edge has +-- a 'RelKind' type. See the +-- for more information. +-- +-- For example: +-- +-- > createRel start "parent" child +createRel :: (OrchestrateData a, OrchestrateData b) + => a -- ^ The originating node. + -> RelKind -- ^ The label for the edge. + -> b -- ^ The target, destination node. + -> OrchestrateIO () +createRel from rel to = void $ apiCheck [] url [] $ \o s -> putWith o s Null + where url = [ tableName from , dataKey from + , "relation", rel + , tableName to, dataKey to + ] + +-- | This removes a relationship (an edge) between two nodes. +-- +-- For example: +-- +-- > deleteRel start "parent" child +deleteRel :: (OrchestrateData a, OrchestrateData b) + => a -- ^ The originating node. + -> RelKind -- ^ The label for the edge. + -> b -- ^ The target, destination node. + -> OrchestrateIO () +deleteRel from rel to = + void $ apiCheck [] url ["purge" := ("true" :: T.Text)] deleteWith + where url = [ tableName from, dataKey from + , "relation", rel + , tableName to, dataKey to + ] diff --git a/src/Database/Orchestrate/KeyValue.hs b/src/Database/Orchestrate/KeyValue.hs new file mode 100644 --- /dev/null +++ b/src/Database/Orchestrate/KeyValue.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + + +{-| +This implements the API. + +Generally, the data stored knows about its own key using via the +'OrchestrateData' class instance defined for it. +-} + + +module Database.Orchestrate.KeyValue + ( + -- * Accessing Data + lookup + , listVals + -- * Adding and Updating Data + , putV + , putKV + , postV + -- * Deleting Data + , deleteV + , deleteKV + , purgeV + , purgeKV + ) where + + +import Control.Applicative +import Control.Arrow +import Control.Error +import Control.Lens +import Control.Monad (join, void) +import Data.Aeson +import qualified Data.Text as T +import Network.Wreq +import Prelude hiding (lookup) + +import Database.Orchestrate.Types +import Database.Orchestrate.Utils + + +-- | This retrieves a value from a collection. +-- +-- > lookup "contacts" "mom" +lookup :: FromJSON v => Collection -> Key -> OrchestrateIO (Maybe v) +lookup c k = + join . fmap (decode . (^.responseBody)) <$> api404 [] [c, k] [] getWith + +-- | This inserts data into the database or updates existing data using +-- a key generated by the 'OrchestrateData' instance. +-- +-- > putV data NoMatch +putV :: OrchestrateData v + => v -- ^ The data to store in the database. + -> IfMatch -- ^ If specified, this operation only succeeds + -- if the ref specified matches the + -- currently stored ref for this data. + -> OrchestrateIO Location -- ^ Returns the location of the data. +putV v = putKV (dataKey v) v + +-- | This inserts data into the database or updates data in the database. +-- This overrides the key provided by the data type's 'OrchestrateData' +-- instance. However, it still requires an implementation of that data type +-- for the collection name. +-- +-- > putKV "key" data NoMatch +putKV :: OrchestrateData v + => Key -- ^ The key to store the data under. + -> v -- ^ The data to store. + -> IfMatch -- ^ If specified, this operation only succeeds + -- if the ref specified matches the currently + -- stored ref for this data. + -> OrchestrateIO Location -- ^ Returns the location of the data. +putKV k v m = + getLocation <$> api (ifMatch m) [tableName v, k] [] (rot putWith v') + where v' = toJSON v + +-- | This inserts data in the database, generating a new database key for +-- it. +-- +-- > postV data +postV :: OrchestrateData v + => v -- ^ The data to store. + -> OrchestrateIO (Location, Maybe Key) -- ^ The 'Location' and key for the data. +postV v = (id &&& firstOf locationKey) . getLocation + <$> api [] [tableName v] [] (rot postWith (toJSON v)) + +-- | This removes data from the database. +-- +-- > deleteV data Nothing +deleteV :: OrchestrateData v + => v -- ^ The data to remove. + -> IfMatch' -- ^ If given, this operation only succeeds + -- if the ref specified matches the currently + -- stored ref for this data. + -> OrchestrateIO () +deleteV v = deleteKV (dataKey v) v + +-- | This removes data from the database. +-- +-- > deleteKV "key" data Nothing +deleteKV :: OrchestrateData v + => Key -- ^ The key the data is stored under. + -> v -- ^ The data to remove. + -> IfMatch' -- ^ If given, this operation only succeeds + -- if the ref specified matches the + -- currently stored ref for this data. + -> OrchestrateIO () +deleteKV k v m = void $ apiCheck (ifMatch' m) [tableName v, k] [] deleteWith + +-- | This purges data from the database. Purging not only removes the data, +-- but also all history and secondary items for it. +-- +-- > purgeV data Nothing +purgeV :: OrchestrateData v + => v -- ^ The data to remove. + -> IfMatch' -- ^ If given, this operation only succeeds + -- if the ref specified matches the + -- currently stored ref for this data. + -> OrchestrateIO () +purgeV v = purgeKV (dataKey v) v + +-- | This purges data from the database. Purging not only removes the data, +-- but also all history and secondary items for it. +-- +-- > purgeKV "key" data Nothing +purgeKV :: OrchestrateData v + => Key -- ^ The key the data is stored under. + -> v -- ^ The data to remove. + -> IfMatch' -- ^ If given, this operation only succeeds + -- if the ref specified matches the + -- currently stored ref for this data. + -> OrchestrateIO () +purgeKV k v m = + void $ apiCheck (ifMatch' m) [tableName v, k] + ["purge" := ("true" :: T.Text)] deleteWith + +-- | This lists all the data in the collection within the range given. +-- +-- > listVals "coll-name" Nothing (Open, Open) +listVals :: FromJSON v + => Collection -- ^ The collection to list data from. + -> Maybe Int -- ^ The maximum number of items to retrieve. + -> Range Key -- ^ The range of keys to query. + -> OrchestrateIO (KVList v) -- ^ Returns a collection of data. +listVals c limit (start, end) = apiCheckDecode [] [c] ps getWith + where ps = catMaybes [ ("limit" :=) <$> limit + , rangeStart "Key" start + , rangeEnd "Key" end + ] diff --git a/src/Database/Orchestrate/Network.hs b/src/Database/Orchestrate/Network.hs new file mode 100644 --- /dev/null +++ b/src/Database/Orchestrate/Network.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} + + +{- | +This module implements some network-oriented utility functions. +-} + +module Database.Orchestrate.Network + ( checkResponse + , checkStatusCode + ) where + + +import qualified Control.Exception as Ex +import Control.Lens +import Network.Wreq + +import Database.Orchestrate.Types + + +-- | This takes a response and checks that the status code passes. +-- +-- If the HTTP status code is not OK, this returns an error in the +-- 'OrchestrateT' monad. +checkResponse :: Monad m => Response a -> OrchestrateT m () +checkResponse = checkStatusCode . view (responseStatus . statusCode) + +-- | This checks the status code. Currently 200 and 204 are OK. Everything +-- else is bad. Bad codes throw an exception in 'OrchestrateT'. +checkStatusCode :: Monad m => Int -> OrchestrateT m () +checkStatusCode 200 = return () +checkStatusCode 204 = return () +checkStatusCode rc = throwError + . Ex.SomeException + . Ex.ErrorCall + $ "Invalid response: " ++ show rc diff --git a/src/Database/Orchestrate/Ref.hs b/src/Database/Orchestrate/Ref.hs new file mode 100644 --- /dev/null +++ b/src/Database/Orchestrate/Ref.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +{- | +This module implements the . + +Refs represent the immutable values that have been associated with a key. +-} + + +module Database.Orchestrate.Ref + ( getRef + , listRefs + ) where + + +import Control.Applicative +import Control.Error +import Control.Lens +import Control.Monad +import Data.Aeson +import Data.Aeson.Types (Parser) +import qualified Data.HashMap.Strict as M +import qualified Data.Text as T +import Network.Wreq + +import Database.Orchestrate.Types +import Database.Orchestrate.Utils + + +-- | This retrieves a ref associated with some data. +-- +-- > getRef "coll-name" "key" "43214321" +getRef :: FromJSON r => Collection -> Key -> Ref -> OrchestrateIO (Maybe r) +getRef c k r = + join . fmap (decode . (^.responseBody)) <$> api404 [] [c, k, "refs", r] [] getWith + +-- | This lists all the values that have been associated with a key in the +-- database. Values are returned last to first. +-- +-- > listRefs "coll-name" "key" Nothing Nothing False +listRefs :: FromJSON v + => Collection -- ^ This is the collection for the data. + -> Key -- ^ This is the key for the data. + -> Maybe Int -- ^ The maximum number of items to return. + -> Maybe Int -- ^ The offset into the total sequence of values. + -> Bool -- ^ Should the values be returned also, or just the 'Path' data? + -> OrchestrateIO (ResultList (TombstoneItem v)) + -- ^ Returns the list of results. +listRefs c k limit offset values = + apiCheckDecode [] [c, k, "refs"] parms getWith + where ifm True = Just + ifm False = const Nothing + parms = catMaybes [ ifm values $ "values" := ("true" :: T.Text) + , ("limit" :=) . show <$> limit + , ("offset" :=) . show <$> offset + ] diff --git a/src/Database/Orchestrate/Search.hs b/src/Database/Orchestrate/Search.hs new file mode 100644 --- /dev/null +++ b/src/Database/Orchestrate/Search.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +{- | +This module implements the . +-} + +-- TODO: Create class for query values. Instantiate on Text and [(Text, +-- Text)], maybe also on ADTs for representing the query structures. + +module Database.Orchestrate.Search + ( query + ) where + + +import Control.Applicative +import Control.Error +import Data.Aeson +import Network.Wreq + +import Database.Orchestrate.Types +import Database.Orchestrate.Utils + + +-- | This performs the query and returns the results. +-- +-- > query "coll-name" "query" (Just 25) Nothing +query :: FromJSON v + => Collection -- ^ The collection to query. + -> QueryText -- ^ The query. + -> Maybe Int -- ^ The maximum number of items to return. + -> Maybe Int -- ^ The offset into the search results. + -> OrchestrateIO (SearchList v) -- ^ Returns the results of the query with their scores. +query c q limit offset = apiCheckDecode [] [c] parms getWith + where parms = catMaybes [Just $ "query" := q + , ("limit" :=) <$> limit + , ("offset" :=) <$> offset + ] diff --git a/src/Database/Orchestrate/Types.hs b/src/Database/Orchestrate/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Orchestrate/Types.hs @@ -0,0 +1,446 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wall #-} + + +-- TODO: Clean this up some. Eeek. + +module Database.Orchestrate.Types + ( + -- * General Types + -- ** Aliases + APIKey + , Collection + , Key + , Ref + , Timestamp + , Location + , RestCall + -- ** Result Limits + , Limit + , Offset + -- ** Conditional API Calls + , IfMatch' + , IfMatch(..) + -- ** Ranges + , Range + , RangeEnd(..) + + -- * Key/Value Types + , KVList + + -- * Ref Types + , TombstoneItem(..) + + -- ** Type Lenses and Prisms + , _TombstoneItem + , _LiveItem + , livePath + , liveTime + , liveValue + , tombstonePath + , tombstoneTime + + -- * Event Types + -- ** Type Aliases + , EventList + , EventType + + -- ** Event Location + , EventPath(..) + , eventPath + , eventPathType + , eventPathTime + , eventPathOrd + + -- ** Event Data + , EventItem(..) + , eventItem + , eventTime + , eventOrd + + -- * Graph Types + , RelKind + , RelList + + -- * Search Types + , QueryText + + -- ** List of Search Results + , SearchList(..) + , searchResults + , searchTotal + + -- ** Single Search Result + , SearchItem(..) + , searchItem + , searchScore + + -- * Session + , Session(..) + , sessionURL + , sessionKey + , sessionVersion + , sessionOptions + + -- * Orchestrate Types + -- ** Data + , OrchestrateData(..) + -- ** Monad Types + , OrchestrateT(..) + , OrchestrateIO + , Orchestrate + + -- * Result Types + -- ** Lists of Results + , ResultList(..) + , resultCount + , resultList + , resultPrev + , resultNext + -- ** Individual Results + , ResultItem(..) + , itemPath + , itemValue + -- ** Rich Item Locations (Paths) + , Path(..) + , itemCollection + , itemKey + , itemRef + + -- * Re-exports + -- ** Accessing Data + , ask + , asks + -- ** Throwing and Handling Errors + , throwError + , catchError + ) where + + +import Control.Applicative +import Control.Error +import qualified Control.Exception as Ex +import Control.Lens hiding ((.=)) +import Control.Monad +import Control.Monad.Error.Class +import Control.Monad.Reader +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.Default +import qualified Data.HashMap.Strict as M +import qualified Data.Text as T +import Network.Wreq + + +type APIKey = T.Text +type Collection = T.Text +type Key = T.Text +type Ref = T.Text +type Timestamp = Integer +type Location = T.Text +type IfMatch' = Maybe Ref +type Limit = Int +type Offset = Int +type EventType = T.Text +type RelKind = T.Text +type QueryText = T.Text + +-- | This represents a function that makes a call to the Orchestrate API +-- server. It takes 'Options', a URL 'String', and returns a 'Response'. +type RestCall a = Options -> String -> IO (Response a) + +-- | A richer type than 'IfMatch' for specifying conditional calls. +data IfMatch = IfMatch Ref -- ^ Only perform the action if the ref does exist. + | IfNoneMatch Ref -- ^ Only perform the action if the ref does not exist. + | NoMatch -- ^ Always perform the action. + deriving (Show) + +-- | This is a range tuple. Each end can be specified separately. +type Range a = (RangeEnd a, RangeEnd a) + +-- | This represents the end of a range. +data RangeEnd a = Inclusive a -- ^ The end should be inclusive. I.e., it should include @a@. + | Exclusive a -- ^ The end should be exclusive. I.e., it should not include @a@. + | Open -- ^ There is no bound on this end. + deriving (Show, Functor) + +-- | The data for a session with the Orchestrate database. +data Session = Session + { _sessionURL :: !T.Text -- ^ The base URL for the Orchestrate API. + , _sessionKey :: !APIKey -- ^ The API key for accessing the API. + , _sessionVersion :: !Int -- ^ The version of the API. + , _sessionOptions :: !Options -- ^ The baseline set of 'Options' for making + -- wreq calls. This includes the API key. + } deriving (Show) +$(makeLenses ''Session) + +instance Default Session where + def = Session "https://api.orchestrate.io" "" 0 + $ defaults & header "Content-Type" .~ ["application/json"] + & header "Accept" .~ ["application/json"] + +-- | This is a class for data that can be stored in an Orchestrate +-- store. See +-- "Database.Orchestrate.KeyValue" for where this is used. +class (ToJSON a, FromJSON a) => OrchestrateData a where + -- | This is the name of the collection to store this data type in. + tableName :: a -> Collection + -- | This is the key to store the value in. + dataKey :: a -> Key + +-- | The type for the Orchestrate monad. All interactions with the +-- Orchestrate API are run in this monad. It combines a reader over +-- 'Session' data with error handling using 'EitherT' 'Ex.SomeException'. +newtype OrchestrateT m a + = OrchestrateT + { runOrchestrate :: EitherT Ex.SomeException (ReaderT Session m) a } + deriving (Functor, Applicative, Monad) + +instance MonadTrans OrchestrateT where + lift = OrchestrateT . lift . lift + +instance MonadIO m => MonadIO (OrchestrateT m) where + liftIO = OrchestrateT . liftIO . liftIO + +instance Monad m => MonadReader Session (OrchestrateT m) where + ask = OrchestrateT . lift $ ask + local f = OrchestrateT . local f . runOrchestrate + +-- TODO: Need to define this for other monad classes. + +instance Monad m => MonadError Ex.SomeException (OrchestrateT m) where + throwError = OrchestrateT . EitherT . return . Left + catchError a handler = join + . fmap (handler' handler) + . lift + . runReaderT (runEitherT $ runOrchestrate a) + =<< ask + +handler' :: Monad m + => (Ex.SomeException -> OrchestrateT m a) + -> Either Ex.SomeException a + -> OrchestrateT m a +handler' _ (Right v) = return v +handler' f (Left e) = f e + +-- | 'OrchestrateT' over 'Identity'. Only the most useless monad ever. +type Orchestrate = OrchestrateT Identity + +-- | 'OrchestrateT' over 'IO', the way God intended. +type OrchestrateIO = OrchestrateT IO + +-- | This represents the unique access information for a value in the +-- store. +data Path = Path + { _itemCollection :: !Collection -- ^ The collection containing the data. + , _itemKey :: !Key -- ^ The data's key in the collection. + , _itemRef :: !Ref -- ^ The reference to the current version + -- of the value. + } deriving (Show) +$(makeLenses ''Path) + +instance FromJSON Path where + parseJSON (Object o) = Path + <$> o .: "collection" + <*> o .: "key" + <*> o .: "ref" + parseJSON _ = mzero + +instance ToJSON Path where + toJSON (Path c k r) = object [ "collection" .= c + , "key" .= k + , "ref" .= r + ] + +-- | A parameterized list of results returned by an API call. +-- +-- [@i@] the type of the data contained. +data ResultList i = ResultList + { _resultCount :: !Int + , _resultList :: ![i] + , _resultPrev :: !(Maybe Location) + , _resultNext :: !(Maybe Location) + } deriving (Show) +$(makeLenses ''ResultList) + +instance FromJSON r => FromJSON (ResultList r) where + parseJSON (Object o) = ResultList + <$> o .: "count" + <*> o .: "results" + <*> o .:? "prev" + <*> o .:? "next" + parseJSON _ = mzero + +-- | A parameterized single item returned in a collection by an API call. +-- +-- [@p@] the type of the path data to this data. +-- [@v@] the type of the value for this data. +data ResultItem p v = ResultItem + { _itemPath :: !p + , _itemValue :: !v + } deriving (Show) +$(makeLenses ''ResultItem) + +instance (FromJSON p, FromJSON v) => FromJSON (ResultItem p v) where + parseJSON (Object o) = ResultItem + <$> o .: "path" + <*> o .: "value" + parseJSON _ = mzero + +instance (ToJSON p, ToJSON v) => ToJSON (ResultItem p v) where + toJSON (ResultItem p v) = object ["path" .= p, "value" .= v] + +-- | The data necessary to access an event. +data EventPath = EventPath + { _eventPath :: !Path -- ^ The base 'Path' to this data. + , _eventPathType :: !EventType -- ^ The kind of event. + , _eventPathTime :: !Timestamp -- ^ The event's timestamp. + , _eventPathOrd :: !Int -- ^ The event's ordinal number. + } deriving (Show) +$(makeLenses ''EventPath) + +instance FromJSON EventPath where + parseJSON o'@(Object o) = EventPath + <$> parseJSON o' + <*> o .: "type" + <*> o .: "timestamp" + <*> o .: "ordinal" + parseJSON _ = mzero + +instance ToJSON EventPath where + toJSON (EventPath p et ts o) = + Object $ case toJSON p of + Object m -> m `M.union` epm + _ -> epm + where epm = M.fromList [ ("type", toJSON et) + , ("timestamp", toJSON ts) + , ("ordinal", toJSON o) + ] + +-- | One item in an 'EventList'. +-- +-- This data type uses two parameters: +-- +-- [@a@] The type of data being stored for the event. +-- +-- [@b@] A phantom type for the type of data associated with the event. +-- This data must also be stored in Orchestrate using the +-- "Database.Orchestrate.KeyValue" API. +data EventItem a b = EventItem + { _eventItem :: !(ResultItem EventPath a) -- ^ The data itself and the path to it. + , _eventTime :: !Timestamp -- ^ The event's timestamp. + , _eventOrd :: !Int -- ^ The event's ordinal number. + } deriving (Show) +$(makeLenses ''EventItem) + +instance FromJSON a => FromJSON (EventItem a b) where + parseJSON o'@(Object o) = EventItem + <$> parseJSON o' + <*> o .: "timestamp" + <*> o .: "ordinal" + parseJSON _ = mzero + +-- | 'TombstoneItem' data represents the data values in the database. +data TombstoneItem v = + -- | 'TombstoneItem' data are no longer alive. They are simply markers + -- for deleted data. + TombstoneItem { _tombstonePath :: !Path -- ^ The path to the deleted data. + , _tombstoneTime :: !Timestamp -- ^ The timestamp of this data. + } + -- | 'LiveItem' data are still in the database. + | LiveItem { _livePath :: !Path -- ^ The path to the data. + , _liveValue :: !(Maybe v) -- ^ If values are requested, + -- this will contain the data. + , _liveTime :: !Timestamp -- ^ The timestamp for the data. + } + deriving (Show) +$(makeLenses ''TombstoneItem) + +-- | A 'Prism'' into data created with the 'TombstoneItem' constructor. +_TombstoneItem :: Prism' (TombstoneItem v) (TombstoneItem v) +_TombstoneItem = prism' id $ \i -> + case i of + TombstoneItem{} -> Just i + LiveItem{} -> Nothing + +-- | A 'Prism'' into data created with the 'LiveItem' constructor. +_LiveItem :: Prism' (TombstoneItem v) (TombstoneItem v) +_LiveItem = prism' id $ \i -> + case i of + TombstoneItem{} -> Nothing + LiveItem{} -> Just i + +emptyObject :: FromJSON v => Maybe Value -> Parser (Maybe v) +emptyObject (Just o@(Object m)) | M.null m = return Nothing + | otherwise = parseJSON o +emptyObject _ = return Nothing + +instance FromJSON v => FromJSON (TombstoneItem v) where + parseJSON (Object o) = do + let path = o .: "path" + reftime = o .: "reftime" + (Object p) <- o .: "path" + tombstone <- p .:? "tombstone" + case tombstone of + Just (Bool True) -> TombstoneItem <$> path <*> reftime + _ -> LiveItem <$> path <*> (emptyObject =<< o .:? "value") <*> reftime + parseJSON _ = mzero + +-- | A single search item. +data SearchItem v = SearchItem + { _searchItem :: !(ResultItem Path v) + -- ^ The path to the item and the item itself. + , _searchScore :: !Double + -- ^ The item's relevancy to the query. + } deriving (Show) +$(makeLenses ''SearchItem) + +instance FromJSON v => FromJSON (SearchItem v) where + parseJSON o'@(Object o) = SearchItem + <$> parseJSON o' + <*> o .: "score" + parseJSON _ = mzero + +-- | The collection of search results. +data SearchList v = SearchList + { _searchResults :: !(ResultList (SearchItem v)) + -- ^ The list of search results. + , _searchTotal :: !Int + -- ^ The total number of hits for the search. This may be + -- more than the number of results returned. + } deriving (Show) +$(makeLenses ''SearchList) + +instance FromJSON v => FromJSON (SearchList v) where + parseJSON o'@(Object o) = SearchList + <$> parseJSON o' + <*> o .: "total_count" + parseJSON _ = mzero + +-- | A list of events returned by 'listEvents'. +-- +-- This data type uses two parameters: +-- +-- [@a@] The type of data being stored for the event. +-- +-- [@b@] A phantom type for the type of data associated with the event. +-- This data must also be stored in Orchestrate using the +-- "Database.Orchestrate.KeyValue" API. +type EventList a b = ResultList (EventItem a b) + +-- | A list of edges returned by 'getRel'. +-- +-- This datatype uses two parameters: +-- +-- [@a@] The data type for the edge's origin node. +-- [@b@] The data type for the edge's target node. +type RelList a b = ResultList (ResultItem Path b) + +-- | A list of data returned by 'listV'. +-- +-- [@v@] The type of the data contained in the list. +type KVList v = ResultList (ResultItem Path v) diff --git a/src/Database/Orchestrate/Utils.hs b/src/Database/Orchestrate/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Database/Orchestrate/Utils.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wall #-} + + +module Database.Orchestrate.Utils + ( + -- * Type Utilities + -- ** Executing 'OrchestrateIO' Actions + runO + , runO' + -- ** Lifting + , orchestrateEither + , io + + -- * API Infrastructure + , api + , api' + , api404 + , apiCheck + , apiCheckDecode + + -- * API Functions + , ping + + -- * Data Type Helpers + -- ** Session Utilities + , baseUrl + , buildUrl + , withAuth' + , withAuth + , envSession + + -- ** Match Utilities + , ifMatch + , ifMatch' + + -- ** 'Location' Prisms and Functions + , locationCollection + , locationKey + , locationRef + , locationType + , locationTimestamp + , locationOrdinal + , getLocation + + -- ** Range Utilities + , rangeStart + , rangeEnd + + -- * General Utilities + , rot + , tshow + , initTail + ) where + + +import Control.Applicative +import Control.Error +import Control.Exception as Ex +import Control.Lens +import Control.Monad.Error.Class +import Control.Monad.Reader +import Data.Aeson +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Lazy as BSL +import Data.Default +import qualified Data.List as L +import Data.Monoid +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import qualified Data.Text.Read as TR +import Network.HTTP.Client hiding (responseBody) +import Network.HTTP.Types +import Network.Wreq +import Network.Wreq.Types hiding (auth, headers, params) +import System.Environment + +import Database.Orchestrate.Network +import Database.Orchestrate.Types + + +-- | Pings the Orchestrate API. +ping :: OrchestrateIO () +ping = checkResponse =<< api [] [] [] headWith + +-- | Run an 'OrchestrateT' action with a 'Session' that does /not/ include +-- authentication. This function will add proper authentication before +-- running the action. +runO :: Monad m => OrchestrateT m a -> Session -> m (Either Ex.SomeException a) +runO m s = runO' m $ over sessionOptions (withAuth $ s ^. sessionKey) s + +-- | Run an 'OrchestrateT' action with a 'Session' that already includes +-- authentication. +-- +-- This is the most minimal handler. +runO' :: Monad m => OrchestrateT m a -> Session -> m (Either Ex.SomeException a) +runO' m = runReaderT (runEitherT $ runOrchestrate m) + +-- | Lifts an IO action into the 'OrchestrateT' monad. +io :: MonadIO m => IO a -> OrchestrateT m a +io = OrchestrateT . syncIO + +-- | Lifts an 'Either' value into the 'OrchestrateT' monad. +orchestrateEither :: Monad m + => Either Ex.SomeException a -> OrchestrateT m a +orchestrateEither = OrchestrateT . hoistEither + +-- | Create the base Orchestrate API URL given the current 'Session'. +baseUrl :: Monad m => OrchestrateT m T.Text +baseUrl = do + Session{..} <- ask + return $ mconcat [_sessionURL, "/v", tshow _sessionVersion] + +-- | Adds the API key to the default 'Options'. +withAuth' :: APIKey -> Options +withAuth' key = withAuth key defaults + +-- | Adds the API key to a set of wreq 'Options'. +withAuth :: APIKey -> Options -> Options +withAuth key o = o & auth .~ basicAuth (E.encodeUtf8 key) "" + +-- | Builds a URL from its assembled parts. +buildUrl :: Monad m + => [T.Text] -- ^ The parts of the URL path. These are joined by @/@. + -> OrchestrateT m String -- ^ Returns the URL as a 'String'. +buildUrl paths = do + Session{_sessionURL, _sessionVersion} <- ask + return . T.unpack + . E.decodeUtf8 + . BSL.toStrict + . B.toLazyByteString + . mconcat + . mappend [ textb _sessionURL + , "/v", B.intDec _sessionVersion + , "/" + ] + . L.intersperse "/" + $ map textb paths + where textb = B.byteString . E.encodeUtf8 + +augmentOptions :: RequestHeaders -> [FormParam] -> Options -> Options +augmentOptions hdrs pairs o = o & headers .~ hdrs + & params .~ map pair pairs + where bstext = E.decodeUtf8 + pair (k := v) = (bstext k, bstext $ renderFormValue v) + +-- | This assembles and performs an API call. +api :: RequestHeaders -- ^ Additional HTTP headers. + -> [T.Text] -- ^ The parts of the URL path. + -> [FormParam] -- ^ The form parameters. + -> RestCall a -- ^ The wreq function to make the call. + -> OrchestrateIO (Response a) -- ^ Returns the call's response. +api hdrs paths pairs f = do + opts <- views sessionOptions $ augmentOptions hdrs pairs + io . f opts =<< buildUrl paths + +-- | This assembles and peforms an API call, lifting any status code errors +-- out of the monad and returning them in an explicit 'Either'. +api' :: RequestHeaders -- ^ Additional HTTP headers. + -> [T.Text] -- ^ The parts of the URL path. + -> [FormParam] -- ^ The form parameters. + -> RestCall a -- ^ The wreq function to make the call. + -> OrchestrateIO (Either Status (Response a)) + -- ^ Returns either the error status or + -- the response. +api' hdrs paths pairs f = do + opts <- views sessionOptions $ augmentOptions hdrs pairs + url <- buildUrl paths + io $ fmap Right (f opts url) `Ex.catch` handler + where handler (StatusCodeException s _ _) = return $ Left s + handler e = throwIO e + +-- | This assembles and performs an API call and checks that the status +-- passes 'checkResponse'. +apiCheck :: RequestHeaders -- ^ Additional HTTP headers. + -> [T.Text] -- ^ The parts of the URL path. + -> [FormParam] -- ^ The form parameters. + -> RestCall a -- ^ The wreq function to make the call. + -> OrchestrateIO (Response a) -- ^ Returns the verified response. +apiCheck rh rpath rparams handler = do + r <- api rh rpath rparams handler + checkResponse r + return r + +-- | This assembles and performs an API call. Afterward it checks the +-- status code and decodes the JSON response. +apiCheckDecode :: FromJSON a + => RequestHeaders -- ^ Additional HTTP headers. + -> [T.Text] -- ^ The parts of the URL path. + -> [FormParam] -- ^ The form parameters. + -> RestCall BSL.ByteString -- ^ The wreq function to make the call. + -> OrchestrateIO a -- ^ Returns the verified, decoded response. +apiCheckDecode rh rpath rparams handler = + apiCheck rh rpath rparams handler + >>= orchestrateEither . fmapL errex . eitherDecode . (^. responseBody) + where errex = Ex.SomeException . Ex.ErrorCall + +-- | This assembles and performs an API call. It returns 'Nothing' if the +-- call returns a 404 status code. +api404 :: Show a + => RequestHeaders -- ^ Additional HTTP headers. + -> [T.Text] -- ^ The parts of the URL path. + -> [FormParam] -- ^ The form parameters. + -> RestCall a -- ^ The wreq function to make the call. + -> OrchestrateIO (Maybe (Response a)) -- ^ Returns maybe the response. +api404 hdrs pths parms f = do + s <- ask + er <- liftIO $ Ex.catchJust + Ex.fromException + (fmapL filterStatusCode <$> runO' (api hdrs pths parms f) s) + handler + case er of + Right r -> checkResponse r >> return (Just r) + Left (Just (StatusCodeException (Status 404 _) _ _)) -> return Nothing + Left (Just e) -> throwSome e + Left Nothing -> throwSome $ StatusCodeException status418 [] mempty + + where + handler :: HttpException -> IO (Either (Maybe HttpException) a) + handler e@(StatusCodeException{}) = return . Left $ Just e + handler e = Ex.throw e + + onlyStatusCode :: HttpException -> Maybe HttpException + onlyStatusCode e@(StatusCodeException{}) = Just e + onlyStatusCode _ = Nothing + + filterStatusCode :: Ex.SomeException -> Maybe HttpException + filterStatusCode = join . fmap onlyStatusCode . Ex.fromException + + throwSome :: (Ex.Exception e, Monad m, MonadError Ex.SomeException m) + => e -> m a + throwSome = throwError . Ex.SomeException + +-- | This returns the 'Session' with the API key taken from the +-- @ORCHESTRATE_API@ environment variable. +-- +-- The value of 'sessionOptions' will include authentication. +envSession :: IO Session +envSession = do + key <- T.pack <$> getEnv "ORCHESTRATE_API" + return $ def & sessionKey .~ key + & over sessionOptions (withAuth key) + +-- | This takes a three-parameter function and rotates the parameters to +-- return a function that takes the third parameter first. +rot :: (a -> b -> c -> d) -> c -> a -> b -> d +rot f c a b = f a b c + +-- | Takes an 'IfMatch'' and returns a list of request headers. +ifMatch' :: IfMatch' -> [Header] +ifMatch' (Just r) = [("If-Match", E.encodeUtf8 r)] +ifMatch' Nothing = [] + +-- | Takes an 'IfMatch' and returns a list of request headers. +ifMatch :: IfMatch -> [Header] +ifMatch (IfMatch r) = [("If-Match", E.encodeUtf8 r)] +ifMatch (IfNoneMatch r) = [("If-None-Match", E.encodeUtf8 r)] +ifMatch NoMatch = [] + +loc :: Int -> Prism' T.Text T.Text +loc n = prism' (mappend $ T.replicate (n - 1) "/") + ((`atMay` n) . T.split (=='/')) + +locint :: (Integral i, Show i) => Int -> Prism' T.Text i +locint n = prism' (mappend prefix . T.pack . show) + ( join + . fmap (hush . fmap fst . TR.decimal) + . (`atMay` n) + . T.split (=='/')) + where prefix = T.replicate (n - 1) "/" + +-- | A prism over the collection part of a 'Location' URL. +locationCollection :: Prism' T.Text T.Text +locationCollection = loc 2 + +-- | A prism over the key part of a 'Location' URL. +locationKey :: Prism' T.Text T.Text +locationKey = loc 3 + +-- | A prism over the ref part of a 'Location' URL. +locationRef :: Prism' T.Text T.Text +locationRef = loc 5 + +-- | A prism over the type part of a 'Location' URL from an event +-- operation. +locationType :: Prism' T.Text T.Text +locationType = loc 5 + +-- | A prism over the timestamp part of a 'Location' URL from an event +-- operation. +locationTimestamp :: Prism' T.Text Integer +locationTimestamp = locint 6 + +-- | A prism over the ordinal part of a 'Location' URL from an event +-- operation. +locationOrdinal :: Prism' T.Text Int +locationOrdinal = locint 7 + +-- | Retrieves the 'Location' from a response's headers. +getLocation :: Response a -> T.Text +getLocation = E.decodeUtf8 . view (responseHeader "Location") + +-- | Given a starting 'RangeEnd', return the form parameter. +rangeStart :: FormValue a + => BS.ByteString -- ^ The suffix for the form parameter. + -> RangeEnd a -- ^ The 'RangeEnd'. + -> Maybe FormParam -- ^ Returns the form parameter. +rangeStart k (Inclusive r) = Just $ ("start" <> k) := r +rangeStart k (Exclusive r) = Just $ ("after" <> k) := r +rangeStart _ Open = Nothing + +-- | Given an ending 'RangeEnd', return the form parameter. +rangeEnd :: FormValue a + => BS.ByteString -- ^ The suffix for the form parameter. + -> RangeEnd a -- ^ The 'RangeEnd'. + -> Maybe FormParam -- ^ Returns the form parameter. +rangeEnd k (Inclusive r) = Just $ ("end" <> k) := r +rangeEnd k (Exclusive r) = Just $ ("before" <> k) := r +rangeEnd _ Open = Nothing + +-- | Show data as 'T.Text'. +tshow :: Show a => a -> T.Text +tshow = T.pack . show + +-- | Returns both the last item in a list and the list's 'init'. +-- +-- If the list is empty, it will return @(Nothing, [])@. Otherwise, it's an +-- optimized call to @(lastMay &&& initSafe)@. +initTail :: [a] -> (Maybe a, [a]) +initTail [] = (Nothing, []) +initTail [x] = (Just x, []) +initTail (x:xs) = (x:) <$> initTail xs