orion-hs (empty) → 0.1.1.0
raw patch · 8 files changed
+556/−0 lines, 8 filesdep +aesondep +aeson-better-errorsdep +aeson-casingsetup-changed
Dependencies added: aeson, aeson-better-errors, aeson-casing, base, base64-bytestring, bytestring, containers, exceptions, hslogger, http-api-data, http-client, http-types, iso8601-time, lens, mtl, string-conversions, text, time, unordered-containers, word8, wreq
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +4/−0
- Setup.hs +2/−0
- orion-hs.cabal +53/−0
- src/Orion.hs +7/−0
- src/Orion/Client.hs +248/−0
- src/Orion/Types.hs +209/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for orion-hs++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Corentin Dupont (c) 2019++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,4 @@+orion-hs+========++Orion-hs is a library to access the [FIWARE Orion](https://fiware-orion.readthedocs.io/en/master/) data broker in Haskell.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ orion-hs.cabal view
@@ -0,0 +1,53 @@+cabal-version: 1.12+name: orion-hs+version: 0.1.1.0+description: Please see the README on GitHub at <https://github.com/cdupont/orion-hs#readme>+homepage: https://github.com/cdupont/orion-hs#readme+bug-reports: https://github.com/cdupont/orion-hs/issues+author: Corentin Dupont+maintainer: corentin.dupont@gmail.com+copyright: 2019 Corentin Dupont+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/githubuser/orion-hs++library+ exposed-modules:+ Orion+ , Orion.Types+ , Orion.Client+ other-modules:+ Paths_orion_hs+ hs-source-dirs:+ src+ build-depends:+ base >=4.7 && <5+ , http-client+ , lens+ , mtl+ , word8+ , bytestring+ , text+ , aeson+ , aeson-casing+ , aeson-better-errors+ , http-api-data+ , http-types+ , hslogger+ , string-conversions+ , wreq+ , base64-bytestring+ , exceptions+ , unordered-containers+ , time+ , iso8601-time+ , containers+ default-language: Haskell2010+
+ src/Orion.hs view
@@ -0,0 +1,7 @@++module Orion (+ module Orion.Client,+ module Orion.Types) where++import Orion.Client+import Orion.Types
+ src/Orion/Client.hs view
@@ -0,0 +1,248 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Orion.Client where++import Network.Wreq as W+import Network.Wreq.Types+import Network.HTTP.Client (HttpException)+import Network.HTTP.Types.Method+import Network.HTTP.Types+import Data.Aeson as JSON hiding (Options)+import Data.Aeson.BetterErrors as AB+import Data.Aeson.Casing+import Data.Text as T hiding (head, tail, find, map, filter, singleton, empty)+import Data.Text.Encoding as TE+import Data.Maybe+import Data.Aeson.BetterErrors.Internal+import Data.Time+import Data.Time.ISO8601+import Data.Foldable as F+import Data.Monoid+import Data.Map hiding (lookup, drop)+import qualified Data.HashMap.Strict as H+import qualified Data.ByteString.Char8 as C8+import qualified Data.ByteString.Lazy as BL+import Data.String.Conversions+import Control.Lens hiding ((.=))+import Control.Monad.Reader+import Control.Monad.Except (ExceptT, throwError, MonadError, catchError)+import Control.Exception hiding (try)+import qualified Control.Monad.Catch as C+import Orion.Types+import System.Log.Logger+import GHC.Generics (Generic)+import Debug.Trace++-- * Entities++getEntities :: Maybe Text -> Orion [Entity]+getEntities mq = do+ let qq = case mq of+ Just q -> [("q", Just $ encodeUtf8 q)]+ Nothing -> []+ let (query :: Query) = qq ++ [("limit", Just $ encodeUtf8 "1000")]+ body <- orionGet (decodeUtf8 $ "/v2/entities" <> (renderQuery True query))+ case eitherDecode body of+ Right ret -> do+ debug $ "Orion success: " ++ (show ret) + return ret+ Left (e :: String) -> do+ debug $ "Orion parse error: " ++ (show e) + throwError $ ParseError $ pack (show e)+++postEntity :: Entity -> Orion SubId +postEntity e = do+ debug $ convertString $ "Entity: " <> (JSON.encode e)+ res <- orionPost "/v2/entities" (toJSON e)+ return $ SubId $ convertString res++getEntity :: EntityId -> Orion Entity+getEntity (EntityId eid) = do+ body <- orionGet ("/v2/entities/" <> eid)+ case eitherDecode body of+ Right ret -> do+ debug $ "Orion success: " ++ (show ret) + return ret+ Left (e :: String) -> do+ debug $ "Orion parse error: " ++ (show e) + throwError $ ParseError $ pack (show e)++deleteEntity :: EntityId -> Orion ()+deleteEntity (EntityId eid) = orionDelete ("/v2/entities/" <> eid)++postAttribute :: EntityId -> (AttributeId, Attribute) -> Orion ()+postAttribute (EntityId eid) (attId, att) = do+ debug $ "Post attribute: " <> (convertString $ JSON.encode att)+ void $ orionPost ("/v2/entities/" <> eid <> "/attrs") (toJSON $ singleton attId att)++postTextAttributeOrion :: EntityId -> AttributeId -> Text -> Orion ()+postTextAttributeOrion (EntityId eid) attId val = do+ debug $ convertString $ "put attribute in Orion: " <> val+ void $ orionPost ("/v2/entities/" <> eid <> "/attrs") (toJSON $ fromList [getSimpleAttr attId val])++deleteAttribute :: EntityId -> AttributeId -> Orion ()+deleteAttribute (EntityId eid) (AttributeId attId) = do+ debug $ "Delete attribute"+ orionDelete ("/v2/entities/" <> eid <> "/attrs/" <> attId)+++-- * Subscriptions++getSubs :: Orion [Subscription]+getSubs = do + debug $ "Get subscriptions"+ body <- orionGet ("/v2/subscriptions/")+ debug $ "Orion body : " ++ (show body) + case eitherDecode body of+ Right ret -> do+ debug $ "Orion success: " ++ (show ret) + return ret+ Left (err2 :: String) -> do+ debug $ "Orion parse error: " ++ (show err2) + throwError $ ParseError $ pack (show err2)++postSub :: Subscription -> Orion SubId +postSub e = do+ debug $ convertString $ "PostSubscription: " <> (JSON.encode e)+ res <- orionPost "/v2/subscriptions" (toJSON e)+ debug $ "Orion resp: " ++ (show res)+ return $ SubId $ convertString res++getSub :: SubId -> Orion Subscription+getSub (SubId eid) = do+ body <- orionGet ("/v2/subscriptions/" <> eid)+ debug $ "Orion success: " ++ (show body) + case eitherDecode body of+ Right ret -> do+ debug $ "Orion success: " ++ (show ret) + return ret+ Left (err2 :: String) -> do+ debug $ "Orion parse error: " ++ (show err2) + throwError $ ParseError $ pack (show err2)++deleteSub :: SubId -> Orion ()+deleteSub (SubId sid) = orionDelete ("/v2/subscriptions/" <> sid)++patchSub :: SubId -> Map Text Text -> Orion () +patchSub (SubId eid) patch = do+ orionPatch ("/v2/subscriptions/" <> eid) (toJSON patch)++-- * Requests to Orion.++-- Get Orion URI and options+getOrionDetails :: Path -> Orion (String, Options)+getOrionDetails path = do+ orionOpts@(OrionConfig baseUrl service) <- ask + let opts = defaults &+ header "Fiware-Service" .~ [convertString service] &+ param "attrs" .~ ["dateModified,dateCreated,*"] &+ param "metadata" .~ ["dateModified,dateCreated,*"] + let url = (unpack $ baseUrl <> path) + return (url, opts)++orionGet :: Path -> Orion BL.ByteString +orionGet path = do + (url, opts) <- getOrionDetails path + info $ "Issuing ORION GET with url: " ++ (show url) + debug $ " headers: " ++ (show $ opts ^. W.headers) + eRes <- C.try $ liftIO $ W.getWith opts url+ case eRes of + Right res -> do+ return $ fromJust $ res ^? responseBody+ Left err -> do+ warn $ "Orion HTTP error: " ++ (show err)+ throwError $ HTTPError err++orionPost :: (Postable dat, Show dat) => Path -> dat -> Orion Text +orionPost path dat = do + (url, opts) <- getOrionDetails path + info $ "Issuing ORION POST with url: " ++ (show url) + debug $ " data: " ++ (show dat) + debug $ " headers: " ++ (show $ opts ^. W.headers) + eRes <- C.try $ liftIO $ W.postWith opts url dat+ debug $ " resp: " ++ (show eRes) + case eRes of + Right res -> do+ let headers = fromJust $ res ^? responseHeaders+ return $ T.drop 18 $ convertString $ fromJust $ lookup "Location" headers+ Left err -> do+ warn $ "Orion HTTP Error: " ++ (show err)+ throwError $ HTTPError err++orionDelete :: Path -> Orion ()+orionDelete path = do + (url, opts) <- getOrionDetails path + info $ "Issuing ORION DELETE with url: " ++ (show url) + debug $ " headers: " ++ (show $ opts ^. W.headers) + eRes <- C.try $ liftIO $ W.deleteWith opts url+ case eRes of + Right res -> return ()+ Left err -> do+ warn $ "Orion HTTP Error: " ++ (show err)+ throwError $ HTTPError err++orionPut :: (Putable dat, Show dat) => Path -> dat -> Orion ()+orionPut path dat = do + (url, opts) <- getOrionDetails path + info $ "Issuing ORION PUT with url: " ++ (show url) + debug $ " data: " ++ (show dat) + debug $ " headers: " ++ (show $ opts ^. W.headers) + eRes <- C.try $ liftIO $ W.putWith opts url dat+ case eRes of + Right res -> return ()+ Left err -> do+ warn $ "Orion HTTP Error: " ++ (show err)+ throwError $ HTTPError err++orionPatch :: (Postable dat, Show dat) => Path -> dat -> Orion ()+orionPatch path dat = do + (url, opts) <- getOrionDetails path + info $ "Issuing ORION PATCH with url: " ++ (show url) + debug $ " data: " ++ (show dat) + debug $ " headers: " ++ (show $ opts ^. W.headers) + eRes <- C.try $ liftIO $ W.customPayloadMethodWith "PATCH" opts url dat+ case eRes of + Right res -> return ()+ Left err -> do+ warn $ "Orion HTTP Error: " ++ (show err)+ throwError $ HTTPError err++-- * Helpers++fromSimpleAttribute :: AttributeId -> Map AttributeId Attribute -> Maybe Text+fromSimpleAttribute attId attrs = do+ (Attribute _ mval _) <- attrs !? attId+ val <- mval+ getString val++fromSimpleMetadata :: MetadataId -> Map MetadataId Metadata -> Maybe Text+fromSimpleMetadata mid mets = do+ (Metadata _ mval) <- mets !? mid+ val <- mval+ getString val++getString :: Value -> Maybe Text+getString (String s) = Just s+getString _ = Nothing++getSimpleAttr :: AttributeId -> Text -> (AttributeId, Attribute)+getSimpleAttr attId val = (attId, Attribute "String" (Just $ toJSON val) empty)++getTextMetadata :: MetadataId -> Text -> (MetadataId, Metadata)+getTextMetadata metId val = (metId, Metadata (Just "String") (Just $ toJSON val))++getTimeMetadata :: MetadataId -> UTCTime -> (MetadataId, Metadata)+getTimeMetadata metId val = (metId, (Metadata (Just "DateTime") (Just $ toJSON $ formatISO8601 val)))++debug, warn, info, err :: (MonadIO m) => String -> m ()+debug s = liftIO $ debugM "Orion" s+info s = liftIO $ infoM "Orion" s+warn s = liftIO $ warningM "Orion" s+err s = liftIO $ errorM "Orion" s++try :: MonadError a m => m b -> m (Either a b)+try act = catchError (Right <$> act) (return . Left)+
+ src/Orion/Types.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TemplateHaskell #-}++module Orion.Types where++import Network.Wreq as W hiding (delete)+import Control.Lens hiding ((.=))+import Data.Aeson as JSON+import Data.Aeson.BetterErrors as AB+import Data.Text hiding (head, tail, find, map, filter, drop, toLower)+import Data.String+import GHC.Generics (Generic)+import Data.Maybe+import Data.String.Conversions+import Control.Monad.Reader+import Data.Foldable as F+import Network.HTTP.Client (HttpException)+import Control.Monad.Except (ExceptT, runExceptT)+import qualified Data.HashMap.Lazy as HML +import Data.Map as M hiding (map, drop, toLower)+import Data.Char+import Data.Time+import Debug.Trace++-- * Orion monad++type Orion a = ReaderT OrionConfig (ExceptT OrionError IO) a++data OrionError = HTTPError HttpException -- ^ Keycloak returned an HTTP error.+ | ParseError Text -- ^ Failed when parsing the response+ | EmptyError -- ^ Empty error to serve as a zero element for Monoid.++-- * Orion config++data OrionConfig = OrionConfig {+ _orionUrl :: Text,+ _fiwareService :: Text} deriving (Show, Eq)++defaultOrionConfig = OrionConfig {+ _orionUrl = "http://localhost:1026",+ _fiwareService = "waziup"}++-- | Run an Orion monad within IO.+runOrion :: Orion a -> OrionConfig -> IO (Either OrionError a)+runOrion o conf = runExceptT $ runReaderT o conf++-- * Entities++newtype EntityId = EntityId {unEntityId :: Text} deriving (Show, Eq, Generic, ToJSON, FromJSON)+type EntityType = Text++data Entity = Entity {+ entId :: EntityId,+ entType :: EntityType,+ entAttrs :: Map AttributeId Attribute+ } deriving (Generic, Show)++instance ToJSON Entity where+ toJSON (Entity entId entType attrs) = mergeAeson $ [object ["id" .= entId, "type" .= entType], toJSON attrs]++instance FromJSON Entity where+ parseJSON o@(Object v) = do+ eId <- v .: "id"+ eType <- v .: "type"+ attrs <- parseJSON $ Object (HML.delete "id" $ HML.delete "type" v) + return $ Entity (EntityId eId) eType attrs where++-- * Attributes++newtype AttributeId = AttributeId {unAttributeId :: Text} deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON, FromJSONKey, ToJSONKey, IsString)+type AttributeType = Text++data Attribute = Attribute {+ attType :: AttributeType,+ attValue :: Maybe Value,+ attMetadata :: Map MetadataId Metadata+ } deriving (Generic, Show)++instance ToJSON Attribute where+ toJSON = genericToJSON defaultOptions {fieldLabelModifier = unCapitalize . drop 3}++instance FromJSON Attribute where+ parseJSON = genericParseJSON defaultOptions {fieldLabelModifier = unCapitalize . drop 3}++-- * Metadata++newtype MetadataId = MetadataId {unMeetadataId :: Text} deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON, ToJSONKey, FromJSONKey, IsString)+type MetadataType = Text++data Metadata = Metadata {+ metType :: Maybe MetadataType,+ metValue :: Maybe Value+ } deriving (Generic, Show)++instance ToJSON Metadata where+ toJSON = genericToJSON defaultOptions {fieldLabelModifier = unCapitalize . drop 3}++instance FromJSON Metadata where+ parseJSON = genericParseJSON defaultOptions {fieldLabelModifier = unCapitalize . drop 3}+++-- * Subscriptions++data SubStatus = SubActive | SubInactive | SubFailed | SubExpired deriving (Show, Eq, Generic)++instance FromJSON SubStatus where+ parseJSON = genericParseJSON $ defaultOptions {constructorTagModifier = unCapitalize . drop 3, allNullaryToStringTag = True}++instance ToJSON SubStatus where+ toJSON = genericToJSON $ defaultOptions {constructorTagModifier = unCapitalize . drop 3, allNullaryToStringTag = True}++newtype SubId = SubId {unSubId :: Text} deriving (Show, Eq, Generic, ToJSON, FromJSON)++-- | one subscription+data Subscription = Subscription {+ subId :: Maybe SubId, -- ^ id of the subscription + subDescription :: Text, -- ^ Description+ subSubject :: SubSubject, -- ^ what is subscribed on, and conditions for triggering+ subNotification :: SubNotif, -- ^ what to do when triggered+ subThrottling :: Double, -- ^ minimum interval between two messages in seconds+ subStatus :: Maybe SubStatus,+ subExpires :: Maybe UTCTime+ } deriving (Show, Eq, Generic)++instance ToJSON Subscription where+ toJSON = genericToJSON $ defaultOptions {fieldLabelModifier = unCapitalize . drop 3, omitNothingFields = True}++instance FromJSON Subscription where+ parseJSON = genericParseJSON $ defaultOptions {fieldLabelModifier = unCapitalize . drop 3, omitNothingFields = True}++data SubSubject = SubSubject {+ subEntities :: [SubEntity],+ subCondition :: SubCondition+ } deriving (Show, Eq, Generic)++instance ToJSON SubSubject where+ toJSON = genericToJSON $ defaultOptions {fieldLabelModifier = unCapitalize . drop 3}++instance FromJSON SubSubject where+ parseJSON = genericParseJSON $ defaultOptions {fieldLabelModifier = unCapitalize . drop 3}++data SubEntity = SubEntity {+ subEntId :: EntityId,+ subEntType :: Maybe Text+ } deriving (Show, Eq, Generic)++instance ToJSON SubEntity where+ toJSON = genericToJSON $ defaultOptions {fieldLabelModifier = unCapitalize . drop 6, omitNothingFields = True}++instance FromJSON SubEntity where+ parseJSON = genericParseJSON $ defaultOptions {fieldLabelModifier = unCapitalize . drop 6, omitNothingFields = True}++data SubNotif = SubNotif {+ subHttpCustom :: SubHttpCustom, + subAttrs :: [AttributeId],+ subAttrsFormat :: Text,+ subMetadata :: [Text],+ subTimesSent :: Maybe Int,+ subLastNotification :: Maybe UTCTime,+ subLastSuccess :: Maybe UTCTime,+ subLastFailure :: Maybe UTCTime+ } deriving (Show, Eq, Generic)++instance ToJSON SubNotif where+ toJSON = genericToJSON $ defaultOptions {fieldLabelModifier = unCapitalize . drop 3}++instance FromJSON SubNotif where+ parseJSON = genericParseJSON $ defaultOptions {fieldLabelModifier = unCapitalize . drop 3}++data SubCondition = SubCondition {+ subCondAttrs :: [AttributeId],+ subCondExpression :: Map Text Text+ } deriving (Show, Eq, Generic)++instance ToJSON SubCondition where+ toJSON = genericToJSON $ defaultOptions {fieldLabelModifier = unCapitalize . drop 7}++instance FromJSON SubCondition where+ parseJSON = genericParseJSON $ defaultOptions {fieldLabelModifier = unCapitalize . drop 7}++data SubHttpCustom = SubHttpCustom {+ subUrl :: Text,+ subPayload :: Text,+ subMethod :: Text,+ subHeaders :: Map Text Text+ } deriving (Show, Eq, Generic)++instance ToJSON SubHttpCustom where+ toJSON = genericToJSON $ defaultOptions {fieldLabelModifier = unCapitalize . drop 3}++instance FromJSON SubHttpCustom where+ parseJSON = genericParseJSON $ defaultOptions {fieldLabelModifier = unCapitalize . drop 3}++-- Miscellaneous++type Path = Text++mergeAeson :: [Value] -> Value+mergeAeson = Object . HML.unions . map (\(Object x) -> x)++unCapitalize :: String -> String+unCapitalize (c:cs) = toLower c : cs+unCapitalize [] = []++makeLenses ''OrionConfig