diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for orion-hs + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. 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/orion-hs.cabal b/orion-hs.cabal new file mode 100644 --- /dev/null +++ b/orion-hs.cabal @@ -0,0 +1,53 @@ +cabal-version: 1.12 +name: orion-hs +version: 0.1.1.0 +description: Please see the README on GitHub at +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 + diff --git a/src/Orion.hs b/src/Orion.hs new file mode 100644 --- /dev/null +++ b/src/Orion.hs @@ -0,0 +1,7 @@ + +module Orion ( + module Orion.Client, + module Orion.Types) where + +import Orion.Client +import Orion.Types diff --git a/src/Orion/Client.hs b/src/Orion/Client.hs new file mode 100644 --- /dev/null +++ b/src/Orion/Client.hs @@ -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) + diff --git a/src/Orion/Types.hs b/src/Orion/Types.hs new file mode 100644 --- /dev/null +++ b/src/Orion/Types.hs @@ -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