diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Oleg Grenrus + +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 Oleg Grenrus 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,5 @@ +# flowdock-rest + +[![Build Status](https://travis-ci.org/futurice/haskell-flowdock-rest.svg?branch=master)](https://travis-ci.org/futurice/haskell-flowdock-rest) + +Haskell bingigs to [Flowdock REST API](https://www.flowdock.com/api/rest). 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/fixtures/flows.json b/fixtures/flows.json new file mode 100644 --- /dev/null +++ b/fixtures/flows.json @@ -0,0 +1,43 @@ +[ + { + "id": "deadbeefdeadbeef", + "name": "My flow", + "parameterized_name": "my-flow", + "organization": { + "id": 42, + "name": "Example", + "parameterized_name": "example", + "user_limit": 0, + "user_count": 10, + "active": true, + "url": "https://api.flowdock.com/organizations/example" + }, + "unread_mentions": 0, + "open": true, + "joined": true, + "url": "https://api.flowdock.com/flows/acme/my-flow", + "web_url": "https://www.flowdock.com/app/acme/my-flow", + "join_url": "https://www.flowdock.com/invitations/eedd2bf0643f75c14be9099272429351c7132a71-my-flow", + "access_mode": "organization" + }, + { + "id": "05654aa3-3b13-4a79-8cea-92ed45bdc9a5", + "name": "Another flow", + "parameterized_name": "another-flow", + "organization": { + "id": 8, + "name": "Acme", + "parameterized_name": "acme", + "user_limit": 0, + "user_count": 5, + "active": true, + "url": "https://api.flowdock.com/organizations/acme" + }, + "unread_mentions": 0, + "open": true, + "joined": true, + "url": "https://api.flowdock.com/flows/acme/another-flow", + "web_url": "https://www.flowdock.com/app/acme/another-flow", + "access_mode": "invitation" + } +] diff --git a/fixtures/organisation-users.json b/fixtures/organisation-users.json new file mode 100644 --- /dev/null +++ b/fixtures/organisation-users.json @@ -0,0 +1,11 @@ +[ + { + "id": 9, + "email": "john@example.com", + "name": "John Smith", + "nick": "John", + "avatar": "https://d2cxspbh1aoie1.cloudfront.net/avatars/f0b4520a6e0001636bf8fc1431af151c/", + "website": "http://www.example.com/", + "admin": false + } +] diff --git a/fixtures/organisation.json b/fixtures/organisation.json new file mode 100644 --- /dev/null +++ b/fixtures/organisation.json @@ -0,0 +1,34 @@ +{ + "id": 42, + "parameterized_name": "yup", + "name": "My company", + "user_limit": 80, + "user_count": 2, + "active": true, + "url": "https://api.flowdock.com/organizations/yup", + "subscription": + { + "trial": true, + "trial_ends": "2012-10-26" + }, + "users": [ + { + "id": 1, + "name": "John Smith", + "email": "john@example.com", + "nick": "john", + "avatar": "http://example.com/john.png", + "website": null, + "admin": true + }, + { + "id": 42, + "name": "Stevie Johnson", + "email": "stevie@example.com", + "nick": "stevie", + "avatar": "http://example.com/stevie.png", + "website": "http://example.com", + "admin": false + } + ] +} diff --git a/fixtures/organisations.json b/fixtures/organisations.json new file mode 100644 --- /dev/null +++ b/fixtures/organisations.json @@ -0,0 +1,36 @@ +[ + { + "id": 42, + "parameterized_name": "yup", + "name": "My company", + "user_limit": 80, + "user_count": 2, + "active": true, + "url": "https://api.flowdock.com/organizations/yup", + "subscription": + { + "trial": true, + "trial_ends": "2012-10-26" + }, + "users": [ + { + "id": 1, + "name": "John Smith", + "email": "john@example.com", + "nick": "john", + "avatar": "http://example.com/john.png", + "website": null, + "admin": true + }, + { + "id": 42, + "name": "Stevie Johnson", + "email": "stevie@example.com", + "nick": "stevie", + "avatar": "http://example.com/stevie.png", + "website": "http://example.com", + "admin": false + } + ] + } +] diff --git a/fixtures/users.json b/fixtures/users.json new file mode 100644 --- /dev/null +++ b/fixtures/users.json @@ -0,0 +1,10 @@ +[ + { + "id": 9, + "email": "john@example.com", + "name": "John Smith", + "nick": "John", + "avatar": "https://d2cxspbh1aoie1.cloudfront.net/avatars/f0b4520a6e0001636bf8fc1431af151c/", + "website": "http://www.example.com/" + } +] diff --git a/flowdock-rest.cabal b/flowdock-rest.cabal new file mode 100644 --- /dev/null +++ b/flowdock-rest.cabal @@ -0,0 +1,103 @@ +-- This file has been generated from package.yaml by hpack version 0.7.0. +-- +-- see: https://github.com/sol/hpack + +name: flowdock-rest +version: 0.1.0.0 +synopsis: Flowdock REST API +description: Bindings to the . + . + Currently there are only non-destructive operations. + Also not all types are written out. +category: Web +homepage: https://github.com/futurice/haskell-flowdock-rest#readme +bug-reports: https://github.com/futurice/haskell-flowdock-rest/issues +author: Oleg Grenrus +maintainer: Oleg Grenrus +license: BSD3 +license-file: LICENSE +tested-with: GHC==7.8.4, GHC==7.10.2 +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + fixtures/flows.json + fixtures/organisation-users.json + fixtures/organisation.json + fixtures/organisations.json + fixtures/users.json + README.md + +source-repository head + type: git + location: https://github.com/futurice/haskell-flowdock-rest + +library + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base >=4.7 && <4.9 + , aeson >=0.8 && <0.10 + , ansi-wl-pprint >=0.6 && <0.7 + , binary >=0.7 && <0.8 + , binary-orphans >=0.1.1 && <0.2 + , binary-tagged >=0.1.1 && <0.2 + , bytestring >=0.10 && <0.11 + , deepseq >=1.3 && <1.5 + , exceptions >=0.8 && <0.9 + , generics-sop >=0.1 && <0.2 + , hashable >=1.2 && <1.3 + , http-client >=0.4 && <0.5 + , http-client-tls >=0.2 && <0.3 + , lens >=4.7 && <4.13 + , semigroups >=0.16 && <0.17 + , tagged >=0.7 && <0.9 + , time >=1.4 && <1.6 + , text >=1.2 && <1.3 + , unordered-containers >=0.2 && <0.3 + exposed-modules: + Chat.Flowdock.REST + Chat.Flowdock.REST.Auth + Chat.Flowdock.REST.Common + Chat.Flowdock.REST.Flow + Chat.Flowdock.REST.Internal + Chat.Flowdock.REST.Message + Chat.Flowdock.REST.Organisation + Chat.Flowdock.REST.Request + Chat.Flowdock.REST.URLs + Chat.Flowdock.REST.User + Text.PrettyPrint.ANSI.Leijen.AnsiPretty + default-language: Haskell2010 + +test-suite flowdock-rest-test + type: exitcode-stdio-1.0 + main-is: Tests.hs + hs-source-dirs: + test + ghc-options: -Wall + build-depends: + base >=4.7 && <4.9 + , aeson >=0.8 && <0.10 + , ansi-wl-pprint >=0.6 && <0.7 + , binary >=0.7 && <0.8 + , binary-orphans >=0.1.1 && <0.2 + , binary-tagged >=0.1.1 && <0.2 + , bytestring >=0.10 && <0.11 + , deepseq >=1.3 && <1.5 + , exceptions >=0.8 && <0.9 + , generics-sop >=0.1 && <0.2 + , hashable >=1.2 && <1.3 + , http-client >=0.4 && <0.5 + , http-client-tls >=0.2 && <0.3 + , lens >=4.7 && <4.13 + , semigroups >=0.16 && <0.17 + , tagged >=0.7 && <0.9 + , time >=1.4 && <1.6 + , text >=1.2 && <1.3 + , unordered-containers >=0.2 && <0.3 + , flowdock-rest + , tasty >=0.10 && <0.12 + , tasty-quickcheck >=0.8 && <0.9 + , file-embed >=0.0.9 + default-language: Haskell2010 diff --git a/src/Chat/Flowdock/REST.hs b/src/Chat/Flowdock/REST.hs new file mode 100644 --- /dev/null +++ b/src/Chat/Flowdock/REST.hs @@ -0,0 +1,26 @@ +-- | +-- Module : Chat.Flowdock.REST +-- Description : Flowdock REST api +-- License : BSD3 +-- Maintainer : Oleg Grenrus +-- +-- +module Chat.Flowdock.REST ( + module Chat.Flowdock.REST.Auth, + module Chat.Flowdock.REST.Common, + module Chat.Flowdock.REST.User, + module Chat.Flowdock.REST.Flow, + module Chat.Flowdock.REST.Message, + module Chat.Flowdock.REST.Organisation, + module Chat.Flowdock.REST.URLs, + module Chat.Flowdock.REST.Request, + ) where + +import Chat.Flowdock.REST.Auth +import Chat.Flowdock.REST.Common +import Chat.Flowdock.REST.User +import Chat.Flowdock.REST.Flow +import Chat.Flowdock.REST.Message +import Chat.Flowdock.REST.Organisation +import Chat.Flowdock.REST.URLs +import Chat.Flowdock.REST.Request diff --git a/src/Chat/Flowdock/REST/Auth.hs b/src/Chat/Flowdock/REST/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Chat/Flowdock/REST/Auth.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Chat.Flowdock.REST.Auth +-- License : BSD3 +-- Maintainer : Oleg Grenrus +module Chat.Flowdock.REST.Auth where + +import Data.ByteString.Char8 as BS8 +import Network.HTTP.Client + +-- | Authentication token. +-- +-- See for your token. +newtype AuthToken = AuthToken { getAuthToken :: String } + deriving (Show) + +-- | Add authorisation information to the request +authenticateRequest :: AuthToken -> Request -> Request +authenticateRequest (AuthToken token) = applyBasicAuth username "DUMMY" + where username = BS8.pack token diff --git a/src/Chat/Flowdock/REST/Common.hs b/src/Chat/Flowdock/REST/Common.hs new file mode 100644 --- /dev/null +++ b/src/Chat/Flowdock/REST/Common.hs @@ -0,0 +1,21 @@ +-- | +-- Module : Chat.Flowdock.REST.Common +-- License : BSD3 +-- Maintainer : Oleg Grenrus +module Chat.Flowdock.REST.Common ( + OrganisationId, + FlowId, + UserId, + MessageId, + mkIdentifier, + ApiUrl, + ParamName, + mkParamName, + getParamName, + ) where + +import Chat.Flowdock.REST.Internal +import Chat.Flowdock.REST.User +import Chat.Flowdock.REST.Flow +import Chat.Flowdock.REST.Organisation +import Chat.Flowdock.REST.Message diff --git a/src/Chat/Flowdock/REST/Flow.hs b/src/Chat/Flowdock/REST/Flow.hs new file mode 100644 --- /dev/null +++ b/src/Chat/Flowdock/REST/Flow.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +-- | +-- Module : Chat.Flowdock.REST.Flow +-- License : BSD3 +-- Maintainer : Oleg Grenrus +module Chat.Flowdock.REST.Flow ( + Flow(..), + FlowId, + flowId, + flowAccessMode, + flowName, + flowOrganisation, + flowParamName, + flowUrl, + flowWebUrl, + FlowAccessMode(..), + FlowOrg(..), + ) where + +import Control.Applicative +import Control.DeepSeq +import Control.Lens +import Data.Aeson +import Data.Binary.Orphans +import Data.Binary.Tagged +import Data.Hashable +import Data.Monoid +import Data.Text as T +import GHC.Generics as GHC +import Generics.SOP as SOP +import Text.PrettyPrint.ANSI.Leijen.AnsiPretty + +import Chat.Flowdock.REST.Internal +import Chat.Flowdock.REST.Organisation + +data FlowAccessMode = FAMInvintation + | FAMLink + | FAMOrganisation + deriving (Eq, Ord, Show, Enum, Bounded, GHC.Generic) + +instance NFData FlowAccessMode +instance Hashable FlowAccessMode +instance Binary FlowAccessMode +instance HasStructuralInfo FlowAccessMode +instance HasSemanticVersion FlowAccessMode + +instance FromJSON FlowAccessMode where + parseJSON = withText "Flow access mode" p + where p "invitation" = pure FAMInvintation + p "link" = pure FAMLink + p "organization" = pure FAMOrganisation + p x = fail $ "Invalid flow access mode: " <> T.unpack x + + +instance AnsiPretty FlowAccessMode where + ansiPretty FAMInvintation = text "invintation" + ansiPretty FAMLink = text "link" + ansiPretty FAMOrganisation = text "organisation" + +data FlowOrg = FlowOrg + { _foId :: !OrganisationId + , _foName :: !Text + , _foParamName :: !(ParamName Organisation) + , _foUserLimit :: !Int + , _foUserCount :: !Int + , _foActive :: !Bool + , _foUrl :: !(ApiUrl Organisation) + } + deriving (Eq, Ord, Show, GHC.Generic) + +makeLenses ''FlowOrg + +instance NFData FlowOrg +instance Hashable FlowOrg +instance SOP.Generic FlowOrg +instance SOP.HasDatatypeInfo FlowOrg +instance Binary FlowOrg +instance HasStructuralInfo FlowOrg +instance HasSemanticVersion FlowOrg + +instance FromJSON FlowOrg where + parseJSON = withObject "Flow Org" $ \obj -> + FlowOrg <$> obj .: "id" + <*> obj .: "name" + <*> obj .: "parameterized_name" + <*> obj .: "user_limit" + <*> obj .: "user_count" + <*> obj .: "active" + <*> obj .: "url" + +instance AnsiPretty FlowOrg where + ansiPretty = gAnsiPrettyWith (prettyOpts "_fo") + +instance OrgLike FlowOrg where + orgId = foId + orgName = foName + orgParamName = foParamName + orgUserLimit = foUserLimit + orgUserCount = foUserCount + orgActive = foActive + orgUrl = foUrl + + +data Flow = Flow + { _flowId :: !FlowId + , _flowName :: !Text + , _flowParamName :: !(ParamName Flow) + , _flowOrganisation :: !FlowOrg + , _flowUrl :: !(ApiUrl Flow) + , _flowWebUrl :: !Text + , _flowAccessMode :: !FlowAccessMode + } + deriving (Eq, Ord, Show, GHC.Generic) + +-- | Opaque Flow identifier +type FlowId = Identifier String Flow + +makeLenses ''Flow + +instance NFData Flow +instance Hashable Flow +instance SOP.Generic Flow +instance SOP.HasDatatypeInfo Flow +instance Binary Flow +instance HasStructuralInfo Flow +instance HasSemanticVersion Flow + +instance FromJSON Flow where + parseJSON = withObject "Flow" $ \obj -> + Flow <$> obj .: "id" + <*> obj .: "name" + <*> obj .: "parameterized_name" + <*> obj .: "organization" + <*> obj .: "url" + <*> obj .: "web_url" + <*> obj .: "access_mode" + +instance AnsiPretty Flow where + ansiPretty = gAnsiPrettyWith (prettyOpts "_flow") diff --git a/src/Chat/Flowdock/REST/Internal.hs b/src/Chat/Flowdock/REST/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Chat/Flowdock/REST/Internal.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : Chat.Flowdock.REST.Internal +-- License : BSD3 +-- Maintainer : Oleg Grenrus +module Chat.Flowdock.REST.Internal + ( ApiUrl(..) + , Identifier(..) + , mkIdentifier + , getIdentifier + , ParamName(..) + , mkParamName + , getParamName + ) where + +import Control.Applicative +import Control.DeepSeq +import Data.Aeson +import Data.Binary.Orphans +import Data.Binary.Tagged +import Data.Hashable +import Data.Proxy +import Text.PrettyPrint.ANSI.Leijen.AnsiPretty + +-- | Opaque URL received from the API. +newtype ApiUrl res = ApiUrl String + deriving (Eq, Ord, Show) + +instance NFData (ApiUrl res) where + rnf (ApiUrl url) = rnf url + +instance Hashable (ApiUrl res) where + hashWithSalt salt (ApiUrl url) = hashWithSalt salt url + +instance Binary (ApiUrl res) where + put (ApiUrl url) = put url + get = ApiUrl <$> get + +instance FromJSON (ApiUrl res) where + parseJSON v = ApiUrl <$> parseJSON v + +instance AnsiPretty (ApiUrl res) where + ansiPretty (ApiUrl url) = ansiPretty url + +instance HasStructuralInfo (ApiUrl res) where + structuralInfo _ = NominalNewtype "ApiUrl" $ structuralInfo (Proxy :: Proxy String) + +instance HasSemanticVersion (ApiUrl res) + +-- | Semi-opaque identifier. +newtype Identifier a res = Identifier a + deriving (Eq, Ord, Show) + +instance NFData a => NFData (Identifier a res) where + rnf (Identifier x) = rnf x + +instance Hashable a => Hashable (Identifier a res) where + hashWithSalt salt (Identifier x) = hashWithSalt salt x + +instance Binary a => Binary (Identifier a res) where + put (Identifier x) = put x + get = Identifier <$> get + +instance HasStructuralInfo a => HasStructuralInfo (Identifier a res) where + structuralInfo _ = NominalNewtype "Identifier" $ structuralInfo (Proxy :: Proxy a) + +instance HasSemanticVersion (Identifier a res) + +instance FromJSON a => FromJSON (Identifier a res) where + parseJSON v = Identifier <$> parseJSON v + +instance AnsiPretty a => AnsiPretty (Identifier a res) where + ansiPretty (Identifier a) = ansiPretty a + +mkIdentifier :: a -> Identifier a res +mkIdentifier = Identifier + +getIdentifier :: Identifier a res -> a +getIdentifier (Identifier x) = x + +-- | Semi-opaque parameterised name, used to construct requests +newtype ParamName res = ParamName String + deriving (Eq, Ord, Show) + +mkParamName :: String -> ParamName res +mkParamName = ParamName + +getParamName :: ParamName res -> String +getParamName (ParamName param) = param + +instance NFData (ParamName res) where + rnf (ParamName param) = rnf param + +instance Hashable (ParamName res) where + hashWithSalt salt (ParamName param) = hashWithSalt salt param + +instance Binary (ParamName res) where + put (ParamName param) = put param + get = ParamName <$> get + +instance FromJSON (ParamName res) where + parseJSON v = ParamName <$> parseJSON v + +instance AnsiPretty (ParamName res) where + ansiPretty (ParamName param) = ansiPretty param + +instance HasStructuralInfo (ParamName res) where + structuralInfo _ = NominalNewtype "ParamName" $ structuralInfo (Proxy :: Proxy String) + +instance HasSemanticVersion (ParamName res) diff --git a/src/Chat/Flowdock/REST/Message.hs b/src/Chat/Flowdock/REST/Message.hs new file mode 100644 --- /dev/null +++ b/src/Chat/Flowdock/REST/Message.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +-- | +-- Module : Chat.Flowdock.REST.Message +-- License : BSD3 +-- Maintainer : Oleg Grenrus +module Chat.Flowdock.REST.Message ( + -- * Message + Message(..), + MessageId, + msgContent, + msgTags, + msgCreatedAt, + msgEditedAt, + msgFlowId, + msgId, + msgUser, + -- * Content + MessageEvent(..), + messageEventToString, + messageEventFromString, + MessageContent(..), + _MTStatus, + _MTComment, + _MTAction, + _MTTagChange, + _MTMessageEdit, + _MTActivityUser, + _MTFile, + _MTMail, + _MTActivity, + _MTDiscussion, + -- * Comment + Comment(..), + commentText, + commentTitle, + -- * Mail + Mail(..), + mailSubject, + mailContent, + mailFrom, + mailTo, + mailCc, + mailBcc, + mailReplyTo, + MailAddress(..), + mailAddress, + mailAddressName, + ) where + +import Control.Applicative +import Control.DeepSeq +import Control.Lens +import Data.Aeson +import Data.Binary.Orphans +import Data.Binary.Tagged +import Data.Hashable +import Data.Monoid +import Data.Text as T +import Data.Time +import GHC.Generics as GHC +import Generics.SOP as SOP +import Text.PrettyPrint.ANSI.Leijen.AnsiPretty + +import Chat.Flowdock.REST.Internal +import Chat.Flowdock.REST.User +import Chat.Flowdock.REST.Flow + +data Comment = Comment + { _commentText :: !Text + , _commentTitle :: !Text + } + deriving (Eq, Ord, Show, GHC.Generic) + +makeLenses ''Comment + +instance NFData Comment +instance Hashable Comment +instance SOP.Generic Comment +instance SOP.HasDatatypeInfo Comment +instance Binary Comment +instance HasStructuralInfo Comment +instance HasSemanticVersion Comment + +instance FromJSON Comment where + parseJSON = withObject "Comment" $ \obj -> + Comment <$> obj .: "text" + <*> obj .: "title" + +instance AnsiPretty Comment where + ansiPretty = gAnsiPrettyWith (prettyOpts "_comment") + +data MailAddress = MailAddress + { _mailAddress :: !Text + , _mailAddressName :: !(Maybe Text) + } + deriving (Eq, Ord, Show, GHC.Generic) + +makeLenses ''MailAddress + +instance NFData MailAddress +instance Hashable MailAddress +instance SOP.Generic MailAddress +instance SOP.HasDatatypeInfo MailAddress +instance Binary MailAddress + +instance FromJSON MailAddress where + parseJSON = withObject "MailAddress" $ \obj -> + MailAddress <$> obj .: "address" + <*> obj .:? "name" + +instance AnsiPretty MailAddress where + ansiPretty (MailAddress addr Nothing) = text . T.unpack $ addr + ansiPretty (MailAddress addr (Just name)) = text . T.unpack $ name <> " <" <> addr <> ">" + + +data Mail = Mail + { _mailSubject :: !Text + , _mailContent :: !Text + , _mailTo :: ![MailAddress] + , _mailFrom :: ![MailAddress] + , _mailCc :: ![MailAddress] + , _mailBcc :: ![MailAddress] + , _mailReplyTo :: ![MailAddress] + } + deriving (Eq, Ord, Show, GHC.Generic) + +makeLenses ''Mail + +instance NFData Mail +instance Hashable Mail +instance SOP.Generic Mail +instance SOP.HasDatatypeInfo Mail +instance Binary Mail + +instance FromJSON Mail where + parseJSON = withObject "Mail" $ \obj -> + Mail <$> obj .: "subject" + <*> obj .: "content" + <*> obj .: "to" + <*> obj .: "from" + <*> obj .: "cc" + <*> obj .: "bcc" + <*> obj .: "replyTo" + +instance AnsiPretty Mail where + ansiPretty = gAnsiPrettyWith (prettyOpts "_mail") + +data MessageEvent = EventMessage + | EventStatus + | EventComment -- ^ This message type is likely to change in the near future. + | EventAction + | EventTagChange + | EventMessageEdit + | EventActivityUser + | EventFile + | EventMail + | EventActivity + | EventDiscussion + deriving (Eq, Ord, Show, Enum, Bounded) + +messageEventToString :: MessageEvent -> String +messageEventToString EventMessage = "message" +messageEventToString EventStatus = "status" +messageEventToString EventComment = "comment" +messageEventToString EventAction = "action" +messageEventToString EventTagChange = "tag-change" +messageEventToString EventMessageEdit = "message-edit" +messageEventToString EventActivityUser = "activity.user" +messageEventToString EventFile = "file" +messageEventToString EventMail = "mail" +messageEventToString EventActivity = "activity" +messageEventToString EventDiscussion = "discussion" + +messageEventLookupTable :: [(String, MessageEvent)] +messageEventLookupTable = fmap f [minBound..maxBound] + where f e = (messageEventToString e, e) + +messageEventFromString :: String -> Maybe MessageEvent +messageEventFromString = flip lookup messageEventLookupTable + +data MessageContent = MTMessage !Text + | MTStatus String + | MTComment !Comment -- ^ This message type is likely to change in the near future. + | MTAction !Value + | MTTagChange !Value + | MTMessageEdit !Value + | MTActivityUser !Value + | MTFile !Value + | MTMail !Mail + | MTActivity -- No action + | MTDiscussion + deriving (Eq, Show, GHC.Generic) + +instance NFData MessageContent +instance Hashable MessageContent +instance SOP.Generic MessageContent +instance SOP.HasDatatypeInfo MessageContent +instance Binary MessageContent + +makePrisms ''MessageContent + +instance FromJSON MessageContent where + parseJSON = withObject "Message" $ \obj -> do + event <- obj .: "event" + content <- obj .: "content" + case event of + "message" -> MTMessage <$> parseJSON content + "comment" -> MTComment <$> parseJSON content + "status" -> MTStatus <$> parseJSON content + "action" -> MTAction <$> parseJSON content + "file" -> MTFile <$> parseJSON content + "mail" -> MTMail <$> parseJSON content + "activity" -> pure MTActivity + "discussion" -> pure MTDiscussion + _ -> fail $ "Invalid message type: " <> event + + +instance AnsiPretty MessageContent where + ansiPretty (MTMessage msg) = text "message:" <+> ansiPretty msg + ansiPretty (MTComment com) = ansiPretty com + ansiPretty (MTMail mail) = ansiPretty mail + ansiPretty m = text . show $ m + +data Message = Message + { _msgContent :: !MessageContent + , _msgTags :: ![Text] + , _msgCreatedAt :: !UTCTime + , _msgEditedAt :: !(Maybe UTCTime) + , _msgFlowId :: !FlowId + , _msgUser :: !UserId + , _msgId :: !MessageId + } + deriving (Eq, Show, GHC.Generic) + +-- | Opaque User identifier +type MessageId = Identifier Integer Message + +makeLenses ''Message + +instance NFData Message +-- instance Hashable Message +instance SOP.Generic Message +instance SOP.HasDatatypeInfo Message +instance Binary Message + +instance FromJSON Message where + parseJSON v = do + content <- parseJSON v + flip (withObject "Message") v $ \obj -> + Message <$> pure content + <*> obj .: "tags" + <*> obj .: "created_at" + <*> obj .:? "edited_at" + <*> obj .: "flow" + <*> (mkIdentifier . read <$> obj.: "user") -- User field is string, in future there might be integral `user_id` field. + <*> obj .: "id" + +instance AnsiPretty Message where + ansiPretty = gAnsiPrettyWith (prettyOpts "_msg") diff --git a/src/Chat/Flowdock/REST/Organisation.hs b/src/Chat/Flowdock/REST/Organisation.hs new file mode 100644 --- /dev/null +++ b/src/Chat/Flowdock/REST/Organisation.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +-- | +-- Module : Chat.Flowdock.REST.Organisation +-- License : BSD3 +-- Maintainer : Oleg Grenrus +module Chat.Flowdock.REST.Organisation ( + Organisation(..), + OrganisationId, + OrgLike(..), + orgUsers, + OrgUser(..), + ouAdmin, + ) where + +import Control.Applicative +import Control.DeepSeq +import Control.Lens +import Data.Aeson +import Data.Binary.Orphans +import Data.Binary.Tagged +import Data.Hashable +import Data.Text +import GHC.Generics as GHC +import Generics.SOP as SOP +import Text.PrettyPrint.ANSI.Leijen.AnsiPretty + +import Chat.Flowdock.REST.Internal +import Chat.Flowdock.REST.User + +data OrgUser = OrgUser + { _ouId :: !UserId + , _ouNick :: !Text + , _ouName :: !Text + , _ouEmail :: !Text + , _ouAvatar :: !Text + , _ouWebsite :: !(Maybe Text) + , _ouAdmin :: !Bool + } + deriving (Eq, Ord, Show, GHC.Generic) + +makeLenses ''OrgUser + +instance NFData OrgUser +instance Hashable OrgUser +instance SOP.Generic OrgUser +instance SOP.HasDatatypeInfo OrgUser +instance Binary OrgUser +instance HasStructuralInfo OrgUser +instance HasSemanticVersion OrgUser + +instance FromJSON OrgUser where + parseJSON = withObject "User" $ \obj -> + OrgUser <$> obj .: "id" + <*> obj .: "nick" + <*> obj .: "name" + <*> obj .: "email" + <*> obj .: "avatar" + <*> obj .:? "website" + <*> obj .: "admin" + +instance AnsiPretty OrgUser where + ansiPretty = gAnsiPrettyWith (prettyOpts "_ou") + +instance UserLike OrgUser where + userId = ouId + userNick = ouNick + userName = ouName + userEmail = ouEmail + userAvatar = ouAvatar + userWebsite = ouWebsite + + +data Organisation = Organisation + { _orgId' :: !OrganisationId + , _orgParamName' :: !(ParamName Organisation) + , _orgName' :: !Text + , _orgUserLimit' :: !Int + , _orgUserCount' :: !Int + , _orgActive' :: !Bool + , _orgUrl' :: !(ApiUrl Organisation) + , _orgUsers :: ![OrgUser] + } + deriving (Eq, Ord, Show, GHC.Generic) + +-- | Opaque Organisation identifier +type OrganisationId = Identifier Integer Organisation + +makeLenses ''Organisation + +instance NFData Organisation +instance Hashable Organisation +instance SOP.Generic Organisation +instance SOP.HasDatatypeInfo Organisation +instance Binary Organisation +instance HasStructuralInfo Organisation +instance HasSemanticVersion Organisation + +instance FromJSON Organisation where + parseJSON = withObject "Organisation" $ \obj -> + Organisation <$> obj .: "id" + <*> obj .: "parameterized_name" + <*> obj .: "name" + <*> obj .: "user_limit" + <*> obj .: "user_count" + <*> obj .: "active" + <*> obj .: "url" + <*> obj .: "users" + +instance AnsiPretty Organisation where + ansiPretty = gAnsiPrettyWith (prettyOpts "_org") + +-- | 'Organisation' like structures +class OrgLike o where + orgId :: Lens' o OrganisationId + orgName :: Lens' o Text + orgParamName :: Lens' o (ParamName Organisation) + orgUserLimit :: Lens' o Int + orgUserCount :: Lens' o Int + orgActive :: Lens' o Bool + orgUrl :: Lens' o (ApiUrl Organisation) + +instance OrgLike Organisation where + orgId = orgId' + orgName = orgName' + orgParamName = orgParamName' + orgUserLimit = orgUserLimit' + orgUserCount = orgUserCount' + orgActive = orgActive' + orgUrl = orgUrl' diff --git a/src/Chat/Flowdock/REST/Request.hs b/src/Chat/Flowdock/REST/Request.hs new file mode 100644 --- /dev/null +++ b/src/Chat/Flowdock/REST/Request.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +-- | +-- Module : Chat.Flowdock.REST.Request +-- License : BSD3 +-- Maintainer : Oleg Grenrus +module Chat.Flowdock.REST.Request ( + -- * Request creation + parseApiUrl, + -- * Flows + -- | See + flowsRequest, + allFlowsRequest, + flowRequest, + -- * Messages + -- | See + messagesRequest, + -- ** Options + MessageOptions, + defMessageOptions, + msgOptEvents, + msgOptLimit, + msgOptUntilId, + msgOptSinceId, + msgOptSorting, + Sorting(..), + sortingToString, + -- * Users + -- | See + usersRequest, + orgUsersRequest, + flowUsersRequest, + -- * Organisations + -- | See + organisationsRequest, + organisationRequest, + ) where + +import Control.Applicative +import Control.Lens +import Control.Monad +import Control.Monad.Catch +import Data.Maybe +import Data.List as L +import Data.List.NonEmpty +import Data.String +import Data.Tagged +import Network.HTTP.Client + +import Chat.Flowdock.REST.Internal +import Chat.Flowdock.REST.User +import Chat.Flowdock.REST.Organisation +import Chat.Flowdock.REST.Flow +import Chat.Flowdock.REST.Message + +import Chat.Flowdock.REST.URLs + +-- | Convert a 'ApiUrl' into a 'Request'. +-- +-- See 'Network.HTTP.Client.parseUrl' +-- +-- Since this function uses 'MonadThrow', the return monad can be anything that is an instance of 'MonadThrow', such as 'IO' or 'Maybe'. +parseApiUrl :: MonadThrow m => ApiUrl a -> m (Tagged a Request) +parseApiUrl (ApiUrl url) = Tagged `liftM` parseUrl url + +data Sorting = Descending | Ascending + deriving (Eq, Ord, Read, Show, Enum, Bounded) + +sortingToString :: Sorting -> String +sortingToString Descending = "desc" +sortingToString Ascending = "asc" + +data MessageOptions = MessageOptions + { _msgOptEvents :: [MessageEvent] + , _msgOptLimit :: Maybe Int + , _msgOptUntilId :: Maybe MessageId + , _msgOptSinceId :: Maybe MessageId + , _msgOptSorting :: Sorting + } + deriving (Eq, Ord, Show) + +defMessageOptions :: MessageOptions +defMessageOptions = MessageOptions [] Nothing Nothing Nothing Descending + +makeLenses ''MessageOptions + +messagesRequest :: MonadThrow m => ParamName Organisation -> ParamName Flow -> MessageOptions -> m (Tagged [Message] Request) +messagesRequest org flow MessageOptions {..} = do + req <- parseApiUrl (messagesUrl org flow) + return $ setQueryString queryString <$> req + where queryString = catMaybes [ (\es -> ("event", Just $ fromString $ L.intercalate "," $ toList $ fmap messageEventToString es)) <$> nonEmpty _msgOptEvents + , (\l -> ("limit", Just $ fromString $ show l)) <$> _msgOptLimit + , (\u -> ("until_id", Just $ fromString $ show $ getIdentifier u)) <$> _msgOptUntilId + , (\s -> ("since_id", Just $ fromString $ show $ getIdentifier s)) <$> _msgOptSinceId + , Just ("sort", Just $ fromString $ sortingToString _msgOptSorting) + ] + +-- Flows + +flowsRequest :: MonadThrow m => m (Tagged [Flow] Request) +flowsRequest = parseApiUrl flowsUrl + +allFlowsRequest :: MonadThrow m => m (Tagged [Flow] Request) +allFlowsRequest = parseApiUrl allFlowsUrl + +flowRequest :: MonadThrow m => ParamName Organisation -> ParamName Flow -> m (Tagged Flow Request) +flowRequest org flow = parseApiUrl $ flowGetUrl org flow + +-- Users + +usersRequest :: MonadThrow m => m (Tagged [User] Request) +usersRequest = parseApiUrl usersUrl + +flowUsersRequest :: MonadThrow m => ParamName Organisation -> ParamName Flow -> m (Tagged [User] Request) +flowUsersRequest org flow = parseApiUrl $ flowUsersUrl org flow + +orgUsersRequest :: MonadThrow m => ParamName Organisation -> m (Tagged [User] Request) +orgUsersRequest org = parseApiUrl $ orgUsersUrl org + +-- Organisations + +organisationsRequest :: MonadThrow m => m (Tagged [Organisation] Request) +organisationsRequest = parseApiUrl organisationsUrl + +organisationRequest :: MonadThrow m => ParamName Organisation -> m (Tagged Organisation Request) +organisationRequest org = parseApiUrl $ organisationUrl org diff --git a/src/Chat/Flowdock/REST/URLs.hs b/src/Chat/Flowdock/REST/URLs.hs new file mode 100644 --- /dev/null +++ b/src/Chat/Flowdock/REST/URLs.hs @@ -0,0 +1,65 @@ +-- | +-- Module : Chat.Flowdock.REST.URLs +-- License : BSD3 +-- Maintainer : Oleg Grenrus +module Chat.Flowdock.REST.URLs ( + -- * Flows + -- | See + flowsUrl, + allFlowsUrl, + flowGetUrl, + -- * Messages + -- | See + messagesUrl, + -- * Users + -- | See + usersUrl, + orgUsersUrl, + flowUsersUrl, + -- * Organisations + -- | See + organisationsUrl, + organisationUrl, + ) where + +import Data.List +import Data.Monoid + +import Chat.Flowdock.REST.Internal +import Chat.Flowdock.REST.User +import Chat.Flowdock.REST.Organisation +import Chat.Flowdock.REST.Flow +import Chat.Flowdock.REST.Message + +apiBaseUrl :: String +apiBaseUrl = "https://api.flowdock.com" + +mkUrl :: [String] -> ApiUrl a +mkUrl parts = ApiUrl $ apiBaseUrl <> "/" <> intercalate "/" parts + +flowsUrl :: ApiUrl [Flow] +flowsUrl = mkUrl ["flows"] + +allFlowsUrl :: ApiUrl [Flow] +allFlowsUrl = mkUrl ["flows", "all"] + +flowGetUrl :: ParamName Organisation -> ParamName Flow -> ApiUrl Flow +flowGetUrl (ParamName org) (ParamName flow) = mkUrl ["flows", org, flow] + +messagesUrl :: ParamName Organisation -> ParamName Flow -> ApiUrl [Message] +messagesUrl (ParamName org) (ParamName flow) = mkUrl ["flows", org, flow, "messages"] + +usersUrl :: ApiUrl [User] +usersUrl = mkUrl ["users"] + +flowUsersUrl :: ParamName Organisation -> ParamName Flow -> ApiUrl [User] +flowUsersUrl (ParamName org) (ParamName flow) = mkUrl ["flows", org, flow, "users"] + +orgUsersUrl :: ParamName Organisation -> ApiUrl [User] +orgUsersUrl (ParamName org) = mkUrl ["organizations", org, "users"] + +organisationsUrl :: ApiUrl [Organisation] +organisationsUrl = mkUrl ["organizations"] + +organisationUrl :: ParamName Organisation -> ApiUrl Organisation +organisationUrl (ParamName org) = mkUrl ["organizations", org] diff --git a/src/Chat/Flowdock/REST/User.hs b/src/Chat/Flowdock/REST/User.hs new file mode 100644 --- /dev/null +++ b/src/Chat/Flowdock/REST/User.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +-- | +-- Module : Chat.Flowdock.REST.User +-- License : BSD3 +-- Maintainer : Oleg Grenrus +module Chat.Flowdock.REST.User + ( User(..) + , UserId + , UserLike(..) + ) where + +import Control.Applicative +import Control.DeepSeq +import Control.Lens +import Data.Aeson +import Data.Binary.Orphans +import Data.Binary.Tagged +import Data.Hashable +import Data.Text +import GHC.Generics as GHC +import Generics.SOP as SOP +import Text.PrettyPrint.ANSI.Leijen.AnsiPretty + +import Chat.Flowdock.REST.Internal + +-- | Opaque User identifier +type UserId = Identifier Integer User + +data User = User + { _userId' :: !UserId + , _userEmail' :: !Text + , _userName' :: !Text + , _userNick' :: !Text + , _userAvatar' :: !Text + , _userWebsite' :: !(Maybe Text) + } + deriving (Eq, Ord, Show, GHC.Generic) + +makeLenses ''User + +instance NFData User +instance Hashable User +instance SOP.Generic User +instance SOP.HasDatatypeInfo User +instance Binary User +instance HasStructuralInfo User +instance HasSemanticVersion User + +instance FromJSON User where + parseJSON = withObject "User" $ \obj -> + User <$> obj .: "id" + <*> obj .: "email" + <*> obj .: "name" + <*> obj .: "nick" + <*> obj .: "avatar" + <*> obj .: "website" + +instance AnsiPretty User where + ansiPretty = gAnsiPrettyWith (prettyOpts "_user") + +-- | 'User' like structures. +class UserLike u where + userId :: Lens' u UserId + userName :: Lens' u Text + userEmail :: Lens' u Text + userNick :: Lens' u Text + userAvatar :: Lens' u Text + userWebsite :: Lens' u (Maybe Text) + +instance UserLike User where + userId = userId' + userEmail = userEmail' + userName = userName' + userNick = userNick' + userAvatar = userAvatar' + userWebsite = userWebsite' + diff --git a/src/Text/PrettyPrint/ANSI/Leijen/AnsiPretty.hs b/src/Text/PrettyPrint/ANSI/Leijen/AnsiPretty.hs new file mode 100644 --- /dev/null +++ b/src/Text/PrettyPrint/ANSI/Leijen/AnsiPretty.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DefaultSignatures #-} +-- | +-- Module : Text.Pretty.ANSI.Leijen.AnsiPretty +-- License : BSD3 +-- Maintainer : Oleg Grenrus +-- +-- /Note:/ This module may move into other (own) package. +module Text.PrettyPrint.ANSI.Leijen.AnsiPretty ( + -- * Class + AnsiPretty(..), + -- * Generic + gAnsiPretty, + gAnsiPrettyWith, + AnsiPrettyOpts(..), + defAnsiPrettyOpts, + prettyOpts, + -- * Re-exports + -- | 'Text.PrettyPrint.ANSI.Leijen' + module PP, + ) where + +import Data.Char as C +import Data.List as L +import Data.Text as T +import Data.Monoid ((<>)) +import Data.Time +import Generics.SOP +import Text.PrettyPrint.ANSI.Leijen as PP hiding ((<>), (<$>), semiBraces, Pretty) + +class AnsiPretty a where + ansiPretty :: a -> Doc + + default ansiPretty :: (Generic a, HasDatatypeInfo a, All2 AnsiPretty (Code a)) => a -> Doc + ansiPretty = gAnsiPretty + + ansiPrettyList :: [a] -> Doc + ansiPrettyList = encloseSep (dullgreen lbracket) (dullgreen rbracket) (dullgreen colon) . fmap ansiPretty + +semiBraces :: [Doc] -> Doc +semiBraces = encloseSep (dullblue lbrace) (dullblue rbrace) (dullblue semi) + +prettyField :: AnsiPretty a => String -> a -> Doc +prettyField name value = black (text name) <+> blue equals <+> ansiPretty value + +prettyRecord :: String -> [Doc] -> Doc +prettyRecord name fields = hang 2 (cyan (text name) semiBraces fields) + +data AnsiPrettyOpts = AnsiPrettyOpts + { poPrettyField :: FieldName -> Doc -> Doc + , poPrettyRecord :: ConstructorName -> [Doc] -> Doc + } + +defAnsiPrettyOpts :: AnsiPrettyOpts +defAnsiPrettyOpts = AnsiPrettyOpts prettyField prettyRecord + +-- | 'PrettyOpts' used in @flowdock-rest@ +prettyOpts :: String -> AnsiPrettyOpts +prettyOpts prefix = defAnsiPrettyOpts { poPrettyField = poPrettyField defAnsiPrettyOpts . renamer } + where renamer name| prefix `L.isPrefixOf` name = dropTrailingPrime . lowerFirst . Prelude.drop prefixLen $ name + | otherwise = name + prefixLen = Prelude.length prefix + lowerFirst (x:xs) = C.toLower x : xs + lowerFirst xs = xs + dropTrailingPrime [] = [] + dropTrailingPrime ['\''] = [] + dropTrailingPrime (x:xs) = x : dropTrailingPrime xs + + +gAnsiPrettyWith :: forall a. (Generic a, HasDatatypeInfo a, All2 AnsiPretty (Code a)) => AnsiPrettyOpts -> a -> Doc +gAnsiPrettyWith opts x = gAnsiPrettyS opts (from x) (datatypeInfo (Proxy :: Proxy a)) + +gAnsiPretty :: forall a. (Generic a, HasDatatypeInfo a, All2 AnsiPretty (Code a)) => a -> Doc +gAnsiPretty = gAnsiPrettyWith defAnsiPrettyOpts + +gAnsiPrettyS :: (All2 AnsiPretty xss) => AnsiPrettyOpts -> SOP I xss -> DatatypeInfo xss -> Doc +gAnsiPrettyS _opts (SOP (Z (I x :* Nil))) (Newtype _ _ _) = ansiPretty x +gAnsiPrettyS opts (SOP (Z xs)) (ADT _ _ (ci :* Nil)) = poPrettyRecord opts (constructorName ci) (gAnsiPrettyP opts xs (fieldInfo ci)) +gAnsiPrettyS _opts (SOP (Z _ )) _ = error "gAnsiPrettyS: redundant Z case" +gAnsiPrettyS opts (SOP (S xss)) (ADT m d (_ :* cis)) = gAnsiPrettyS opts (SOP xss) (ADT m d cis) +gAnsiPrettyS _opts (SOP (S _)) _ = error "gAnsiPrettyS: redundant S case" + +gAnsiPrettyP :: (All AnsiPretty xs) => AnsiPrettyOpts -> NP I xs -> NP FieldInfo xs -> [Doc] +gAnsiPrettyP _opts Nil Nil = [] +gAnsiPrettyP opts (I x :* xs) (FieldInfo fieldName :* fis) = poPrettyField opts fieldName (ansiPretty x) : gAnsiPrettyP opts xs fis +gAnsiPrettyP _opts _ _ = error "gAnsiPrettyP: redundant case" + +constructorName :: ConstructorInfo a -> ConstructorName +constructorName (Constructor name) = name +constructorName (Infix name _ _) = name +constructorName (Record name _) = name + +fieldInfo :: ConstructorInfo xs -> NP FieldInfo xs +fieldInfo (Constructor _) = constructorFieldInfos 0 sing +fieldInfo (Infix _ _ _) = FieldInfo "_lhs" :* FieldInfo "_rhs" :* Nil +fieldInfo (Record _ fi) = fi + +constructorFieldInfos :: forall (xs :: [*]). Int -> Sing xs -> NP FieldInfo xs +constructorFieldInfos _ SNil = Nil +constructorFieldInfos n SCons = FieldInfo ("_" <> show n) :* constructorFieldInfos (n+1) sing + +-- Instances + +instance AnsiPretty Integer where + ansiPretty = dullyellow . integer + +instance AnsiPretty Int where + ansiPretty = dullyellow . int + +instance AnsiPretty Doc where + ansiPretty = id + +instance AnsiPretty Bool where + ansiPretty True = dullyellow $ string "True" + ansiPretty False = dullyellow $ string "False" + +instance AnsiPretty Char where + ansiPretty c = string [c] + ansiPrettyList = string + +instance AnsiPretty a => AnsiPretty [a] where + ansiPretty = ansiPrettyList + +instance AnsiPretty a => AnsiPretty (Maybe a) where + ansiPretty (Just x) = ansiPretty x + ansiPretty Nothing = dullcyan (string "Nothing") + +instance AnsiPretty Text where + ansiPretty = ansiPretty . T.unpack + +instance AnsiPretty UTCTime where + ansiPretty = ansiPretty . show diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Main (main) where + +import Data.Aeson +import Data.ByteString.Lazy as BSL +import Data.Either +import Data.FileEmbed +import Data.Proxy +import Test.Tasty +import Test.Tasty.QuickCheck as QC + +import Chat.Flowdock.REST + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" [exampleJsons] + +exampleJsons :: TestTree +exampleJsons = testGroup "Example JSONs" + [ p "List of organisations" $(embedStringFile "fixtures/organisations.json") (Proxy :: Proxy [Organisation]) + , p "Organisation" $(embedStringFile "fixtures/organisation.json") (Proxy :: Proxy Organisation) + , p "List of users " $(embedStringFile "fixtures/users.json") (Proxy :: Proxy [User]) + , p "List of org users" $(embedStringFile "fixtures/organisation-users.json") (Proxy :: Proxy [User]) + , p "List of flows" $(embedStringFile "fixtures/flows.json") (Proxy :: Proxy [Flow]) + ] + where p :: forall a. FromJSON a => String -> ByteString -> Proxy a -> TestTree + p name bs _ = QC.testProperty name $ once $ isRight (eitherDecode bs :: Either String a)