packages feed

flowdock-rest (empty) → 0.1.0.0

raw patch · 21 files changed

+1426/−0 lines, 21 filesdep +aesondep +ansi-wl-pprintdep +basesetup-changed

Dependencies added: aeson, ansi-wl-pprint, base, binary, binary-orphans, binary-tagged, bytestring, deepseq, exceptions, file-embed, flowdock-rest, generics-sop, hashable, http-client, http-client-tls, lens, semigroups, tagged, tasty, tasty-quickcheck, text, time, unordered-containers

Files

+ LICENSE view
@@ -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.
+ README.md view
@@ -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).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ fixtures/flows.json view
@@ -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"+  }+]
+ fixtures/organisation-users.json view
@@ -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+  }+]
+ fixtures/organisation.json view
@@ -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+    }+  ]+}
+ fixtures/organisations.json view
@@ -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+      }+    ]+  }+]
+ fixtures/users.json view
@@ -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/"+  }+]
+ flowdock-rest.cabal view
@@ -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 <https://www.flowdock.com/api/rest Flowdock REST API>.+                .+                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 <oleg.grenrus@iki.fi>+maintainer:     Oleg Grenrus <oleg.grenrus@iki.fi>+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
+ src/Chat/Flowdock/REST.hs view
@@ -0,0 +1,26 @@+-- |+-- Module      : Chat.Flowdock.REST+-- Description : Flowdock REST api+-- License     : BSD3+-- Maintainer  : Oleg Grenrus <oleg.grenrus@iki.fi>+--+-- <https://www.flowdock.com/api/rest Flowdock REST api>+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
+ src/Chat/Flowdock/REST/Auth.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module      : Chat.Flowdock.REST.Auth+-- License     : BSD3+-- Maintainer  : Oleg Grenrus <oleg.grenrus@iki.fi>+module Chat.Flowdock.REST.Auth where++import Data.ByteString.Char8 as BS8+import Network.HTTP.Client++-- | Authentication token.+--+-- See <https://www.flowdock.com/account/tokens> 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
+ src/Chat/Flowdock/REST/Common.hs view
@@ -0,0 +1,21 @@+-- |+-- Module      : Chat.Flowdock.REST.Common+-- License     : BSD3+-- Maintainer  : Oleg Grenrus <oleg.grenrus@iki.fi>+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
+ src/Chat/Flowdock/REST/Flow.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+-- |+-- Module      : Chat.Flowdock.REST.Flow+-- License     : BSD3+-- Maintainer  : Oleg Grenrus <oleg.grenrus@iki.fi>+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")
+ src/Chat/Flowdock/REST/Internal.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module      : Chat.Flowdock.REST.Internal+-- License     : BSD3+-- Maintainer  : Oleg Grenrus <oleg.grenrus@iki.fi>+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)
+ src/Chat/Flowdock/REST/Message.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+-- |+-- Module      : Chat.Flowdock.REST.Message+-- License     : BSD3+-- Maintainer  : Oleg Grenrus <oleg.grenrus@iki.fi>+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")
+ src/Chat/Flowdock/REST/Organisation.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+-- |+-- Module      : Chat.Flowdock.REST.Organisation+-- License     : BSD3+-- Maintainer  : Oleg Grenrus <oleg.grenrus@iki.fi>+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'
+ src/Chat/Flowdock/REST/Request.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+-- |+-- Module      : Chat.Flowdock.REST.Request+-- License     : BSD3+-- Maintainer  : Oleg Grenrus <oleg.grenrus@iki.fi>+module Chat.Flowdock.REST.Request (+  -- * Request creation+  parseApiUrl,+  -- * Flows+  -- | See <https://www.flowdock.com/api/flows>+  flowsRequest,+  allFlowsRequest,+  flowRequest,+  -- * Messages+  -- | See <https://www.flowdock.com/api/messages>+  messagesRequest,+  -- ** Options+  MessageOptions,+  defMessageOptions,+  msgOptEvents,+  msgOptLimit,+  msgOptUntilId,+  msgOptSinceId,+  msgOptSorting,+  Sorting(..),+  sortingToString,+  -- * Users+  -- | See <https://www.flowdock.com/api/users>+  usersRequest,+  orgUsersRequest,+  flowUsersRequest,+  -- * Organisations+  -- | See <https://www.flowdock.com/api/organizations>+  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
+ src/Chat/Flowdock/REST/URLs.hs view
@@ -0,0 +1,65 @@+-- |+-- Module      : Chat.Flowdock.REST.URLs+-- License     : BSD3+-- Maintainer  : Oleg Grenrus <oleg.grenrus@iki.fi>+module Chat.Flowdock.REST.URLs (+  -- * Flows+  -- | See <https://www.flowdock.com/api/flows>+  flowsUrl,+  allFlowsUrl,+  flowGetUrl,+  -- * Messages+  -- | See <https://www.flowdock.com/api/messages>+  messagesUrl,+  -- * Users+  -- | See <https://www.flowdock.com/api/users>+  usersUrl,+  orgUsersUrl,+  flowUsersUrl,+  -- * Organisations+  -- | See <https://www.flowdock.com/api/organizations>+  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]
+ src/Chat/Flowdock/REST/User.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+-- |+-- Module      : Chat.Flowdock.REST.User+-- License     : BSD3+-- Maintainer  : Oleg Grenrus <oleg.grenrus@iki.fi>+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'+
+ src/Text/PrettyPrint/ANSI/Leijen/AnsiPretty.hs view
@@ -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 <oleg.grenrus@iki.fi>+--+-- /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
+ test/Tests.hs view
@@ -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)