line-bot-sdk 0.3.0.0 → 0.4.0.0

raw patch · 11 files changed

+414/−167 lines, 11 filesdep +aeson-qqdep +hspec-expectationsdep −hspec-wai-jsondep ~base64-bytestringdep ~bytestringdep ~cryptohash-sha256PVP ok

version bump matches the API change (PVP)

Dependencies added: aeson-qq, hspec-expectations

Dependencies removed: hspec-wai-json

Dependency ranges changed: base64-bytestring, bytestring, cryptohash-sha256, http-client, http-types, servant, servant-client, servant-client-core, servant-server, text, transformers, wai, warp

API changes (from Hackage documentation)

Files

• README.md +1/−1
• examples/Echo.hs +7/−8
• line-bot-sdk.cabal +20/−5
• src/Line/Bot/Client.hs +47/−20
• src/Line/Bot/Client/Auth.hs +3/−2
• src/Line/Bot/Endpoints.hs +36/−11
• src/Line/Bot/Types.hs +89/−58
• src/Line/Bot/Webhook/Events.hs +38/−42
• test/Line/Bot/ClientSpec.hs +83/−0
• test/Line/Bot/WebhookSpec.hs +89/−0
• test/Spec.hs +1/−20

@@ -1,1 +1,1 @@-# line-bot-sdk+# line-bot-sdk [![Build Status](https://travis-ci.org/moleike/line-bot-sdk.svg?branch=master)](https://travis-ci.org/moleike/line-bot-sdk)

@@ -6,7 +6,7 @@  module Main (main) where -import           Control.Monad                        (mapM_)+import           Control.Monad                        (forM_) import           Control.Monad.IO.Class               (liftIO) import           Control.Monad.Trans.Reader           (ReaderT, ask, runReaderT) import           Data.String                          (fromString)@@ -25,14 +25,14 @@ type API = "webhook" :> Webhook  echo :: Event -> Line NoContent-echo EventMessage { message = W.Text { text }, replyToken } =-  replyMessage replyToken [B.Text text Nothing]+echo EventMessage { message = W.MessageText { text }, replyToken } =+  replyMessage replyToken [B.MessageText text Nothing] echo _ = return NoContent  handleEvents :: [Event] -> WebM NoContent handleEvents events = do   token <- ask-  _     <- liftIO $ mapM_ (flip runLine token . echo) events+  _     <- liftIO $ forM_ events $ flip runLine token . echo   return NoContent  echoServer :: ServerT API WebM@@ -41,10 +41,9 @@ app :: ChannelToken -> ChannelSecret -> Application app token secret = serveWithContext api context server   where-    api     = Proxy :: Proxy API-    server  = hoistServerWithContext api pc nt echoServer-    nt      = flip runReaderT token-    pc      = Proxy :: Proxy '[ChannelSecret]+    api = Proxy :: Proxy API+    pc = Proxy :: Proxy '[ChannelSecret]+    server = hoistServerWithContext api pc (flip runReaderT token) echoServer     context = secret :. EmptyContext  main :: IO ()

@@ -1,5 +1,5 @@ name:                line-bot-sdk-version:             0.3.0.0+version:             0.4.0.0 synopsis:            Haskell SDK for LINE Messaging API homepage:            https://github.com/moleike/line-bot-sdk#readme bug-reports:         https://github.com/moleike/line-bot-sdk/issues@@ -30,10 +30,9 @@   exposed-modules:     Line.Bot.Webhook                      , Line.Bot.Webhook.Events                      , Line.Bot.Client-                     , Line.Bot.Types--  other-modules:       Line.Bot.Endpoints                      , Line.Bot.Client.Auth+                     , Line.Bot.Types+                     , Line.Bot.Endpoints    build-depends:       base                 >= 4.7 && < 5                      , aeson                >= 1.4.2 && < 1.5@@ -79,13 +78,29 @@ test-suite line-bot-sdk-test   type:                exitcode-stdio-1.0   hs-source-dirs:      test+  other-modules:       Line.Bot.WebhookSpec+                     , Line.Bot.ClientSpec   main-is:             Spec.hs   build-depends:       base                      , line-bot-sdk+                     , base64-bytestring+                     , cryptohash-sha256+                     , text+                     , bytestring                      , hspec                      , hspec-wai-                     , hspec-wai-json+                     , hspec-expectations+                     , http-types+                     , http-client                      , aeson+                     , transformers+                     , aeson-qq+                     , servant >= 0.15+                     , servant-server >= 0.15+                     , servant-client >= 0.15+                     , servant-client-core >= 0.15+                     , wai+                     , warp   ghc-options:         -threaded -rtsopts -with-rtsopts=-N   default-language:    Haskell2010 

@@ -16,7 +16,8 @@ module Line.Bot.Client   ( Line   , runLine-  , runLineWith+  , runLine'+  , withLineEnv   -- ** Profile   , getProfile   -- ** Group@@ -30,6 +31,9 @@   , pushMessage   , multicastMessage   , getContent+  , getPushMessageCount+  , getReplyMessageCount+  , getMulticastMessageCount   -- ** Account Link   , issueLinkToken   -- ** OAuth@@ -42,14 +46,13 @@ import           Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) import           Data.ByteString.Lazy       (ByteString) import           Data.Proxy-import           Data.String-import           Data.Text                  as T+import           Data.Time.Calendar         (Day) import           Line.Bot.Client.Auth import           Line.Bot.Endpoints import           Line.Bot.Types import           Network.HTTP.Client        (newManager) import           Network.HTTP.Client.TLS    (tlsManagerSettings)-import           Servant.API                hiding (addHeader)+import           Servant.API import           Servant.Client  host :: BaseUrl@@ -59,22 +62,18 @@ -- OAuth access token for a channel type Line = ReaderT ChannelToken ClientM -defaultClient :: ClientM a -> IO (Either ServantError a)-defaultClient comp = do+withLineEnv :: (ClientEnv -> IO a) -> IO a+withLineEnv app = do   manager <- newManager tlsManagerSettings-  runClientM comp (mkClientEnv manager host)+  app $ mkClientEnv manager host +-- | Executes a request in the LINE plaform (default)+runLine' :: ClientM a -> IO (Either ServantError a)+runLine' comp = withLineEnv $ \env -> runClientM comp env+ -- | Runs a @Line@ computation with the given channel access token runLine :: Line a -> ChannelToken -> IO (Either ServantError a)-runLine = runLineWith defaultClient---- | Runs the monad with a different client evironment-runLineWith-  :: (ClientM a -> IO (Either ServantError a))-  -> Line a-  -> ChannelToken-  -> IO (Either ServantError a)-runLineWith f comp token = f $ runReaderT comp token+runLine comp token = runLine' $ runReaderT comp token  getProfile' :: Auth -> Id User -> ClientM Profile @@ -94,11 +93,17 @@  getContent' :: Auth -> MessageId -> ClientM ByteString +getPushMessageCount' :: Auth -> LineDate -> ClientM MessageCount++getReplyMessageCount' :: Auth -> LineDate -> ClientM MessageCount++getMulticastMessageCount' :: Auth -> LineDate -> ClientM MessageCount+ issueLinkToken' :: Auth -> Id User -> ClientM LinkToken -issueChannelToken :: ClientCredentials -> ClientM ShortLivedChannelToken+issueChannelToken' :: ClientCredentials -> ClientM ShortLivedChannelToken -revokeChannelToken :: ChannelToken -> ClientM NoContent+revokeChannelToken' :: ChannelToken -> ClientM NoContent  getProfile'   :<|> getGroupMemberProfile'@@ -109,9 +114,12 @@   :<|> pushMessage'   :<|> multicastMessage'   :<|> getContent'+  :<|> getPushMessageCount'+  :<|> getReplyMessageCount'+  :<|> getMulticastMessageCount'   :<|> issueLinkToken'-  :<|> issueChannelToken-  :<|> revokeChannelToken = client (Proxy :: Proxy Endpoints)+  :<|> issueChannelToken'+  :<|> revokeChannelToken' = client (Proxy :: Proxy Endpoints)  getProfile :: Id User -> Line Profile getProfile a = ask >>= \token -> lift $ getProfile' (mkAuth token) a@@ -143,9 +151,28 @@   >>= \token -> lift $ multicastMessage' (mkAuth token) body   where body = MulticastMessageBody a ms +-- | TODO: this should use a streaming library for constant memory usage over large data getContent :: MessageId -> Line ByteString getContent a = ask >>= \token -> lift $ getContent' (mkAuth token) a +getPushMessageCount :: Day -> Line MessageCount+getPushMessageCount a =+  ask >>= \token -> lift $ getPushMessageCount' (mkAuth token) (LineDate a)++getReplyMessageCount :: Day -> Line MessageCount+getReplyMessageCount a =+  ask >>= \token -> lift $ getReplyMessageCount' (mkAuth token) (LineDate a)++getMulticastMessageCount :: Day -> Line MessageCount+getMulticastMessageCount a =+  ask >>= \token -> lift $ getMulticastMessageCount' (mkAuth token) (LineDate a)+ issueLinkToken :: Id User -> Line LinkToken issueLinkToken a = ask >>= \token -> lift $ issueLinkToken' (mkAuth token) a++issueChannelToken :: ChannelId -> ChannelSecret -> ClientM ShortLivedChannelToken+issueChannelToken a b = issueChannelToken' $ ClientCredentials a b++revokeChannelToken :: ChannelToken -> ClientM NoContent+revokeChannelToken = revokeChannelToken' 

@@ -17,9 +17,10 @@                                                        mkAuthenticatedRequest) import           Servant.Client.Core.Internal.Request (Request, addHeader) -type Auth = AuthenticatedRequest (AuthProtect ChannelAuth) -type instance AuthClientData (AuthProtect ChannelAuth) = ChannelToken+type instance AuthClientData ChannelAuth = ChannelToken++type Auth = AuthenticatedRequest ChannelAuth  mkAuth :: ChannelToken -> Auth mkAuth token = mkAuthenticatedRequest token addAuthorizationHeader

@@ -21,64 +21,86 @@ import           Servant.API import           Servant.Client -data ChannelAuth+-- | Combinator for authenticating with the channel access token+type ChannelAuth = AuthProtect "channel-access-token" -type GetProfile = AuthProtect ChannelAuth+type GetProfile = ChannelAuth   :> "profile"   :> Capture "userId" (Id User)   :> Get '[JSON] Profile -type GetGroupMemberProfile = AuthProtect ChannelAuth+type GetGroupMemberProfile = ChannelAuth   :> "group"   :> Capture "groupId" (Id Group)   :> "member"   :> Capture "userId" (Id User)   :> Get '[JSON] Profile -type LeaveGroup = AuthProtect ChannelAuth+type LeaveGroup = ChannelAuth   :> "group"   :> Capture "groupId" (Id Group)   :> "leave"   :> PostNoContent '[JSON] NoContent -type GetRoomMemberProfile = AuthProtect ChannelAuth+type GetRoomMemberProfile = ChannelAuth   :> "room"   :> Capture "roomId" (Id Room)   :> "member"   :> Capture "userId" (Id User)   :> Get '[JSON] Profile -type LeaveRoom = AuthProtect ChannelAuth+type LeaveRoom = ChannelAuth   :> "room"   :> Capture "roomId" (Id Room)   :> "leave"   :> PostNoContent '[JSON] NoContent -type ReplyMessage = AuthProtect ChannelAuth+type ReplyMessage = ChannelAuth   :> ReqBody '[JSON] ReplyMessageBody   :> "message"   :> "reply"   :> PostNoContent '[JSON] NoContent -type PushMessage = AuthProtect ChannelAuth+type PushMessage = ChannelAuth   :> ReqBody '[JSON] PushMessageBody   :> "message"   :> "push"   :> PostNoContent '[JSON] NoContent -type MulticastMessage = AuthProtect ChannelAuth+type MulticastMessage = ChannelAuth   :> ReqBody '[JSON] MulticastMessageBody   :> "message"   :> "multicast"   :> PostNoContent '[JSON] NoContent -type GetContent = AuthProtect ChannelAuth+type GetContent = ChannelAuth   :> "message"   :> Capture "messageId" MessageId   :> "content"   :> Get '[OctetStream] ByteString -type IssueLinkToken = AuthProtect ChannelAuth+type GetReplyMessageCount = ChannelAuth+  :> "message"+  :> "delivery"+  :> "reply"+  :> QueryParam' '[Required, Strict] "date" LineDate+  :> Get '[JSON] MessageCount++type GetPushMessageCount = ChannelAuth+  :> "message"+  :> "delivery"+  :> "push"+  :> QueryParam' '[Required, Strict] "date" LineDate+  :> Get '[JSON] MessageCount++type GetMulticastMessageCount = ChannelAuth+  :> "message"+  :> "delivery"+  :> "multicast"+  :> QueryParam' '[Required, Strict] "date" LineDate+  :> Get '[JSON] MessageCount++type IssueLinkToken = ChannelAuth   :> "user"   :> Capture "userId" (Id User)   :> "linkToken"@@ -106,6 +128,9 @@   :<|> PushMessage   :<|> MulticastMessage   :<|> GetContent+  :<|> GetReplyMessageCount+  :<|> GetPushMessageCount+  :<|> GetMulticastMessageCount   :<|> IssueLinkToken   :<|> IssueChannelToken   :<|> RevokeChannelToken

@@ -22,6 +22,7 @@ module Line.Bot.Types   ( ChannelToken(..)   , ChannelSecret(..)+  , ChannelId(..)   , ChatType(..)   , Id(..)   , MessageId@@ -38,9 +39,12 @@   , Action(..)   , ClientCredentials(..)   , ShortLivedChannelToken(..)+  , LineDate(..)+  , MessageCount(..)   ) where +import           Control.Arrow         ((>>>)) import           Data.Aeson import           Data.Aeson.Types import qualified Data.ByteString.Char8 as B@@ -51,12 +55,15 @@ import           Data.String import           Data.Text             as T hiding (drop, toLower) import           Data.Text.Encoding+import           Data.Time.Calendar    (Day)+import           Data.Time.Format import           GHC.Generics          hiding (to) import           Servant.API import           Text.Show import           Web.FormUrlEncoded    (ToForm (..)) -newtype ChannelToken = ChannelToken Text++newtype ChannelToken = ChannelToken { unChannelToken :: Text }   deriving (Eq, Show, Generic)  instance FromJSON ChannelToken@@ -65,13 +72,13 @@   fromString s = ChannelToken (fromString s)  instance ToHttpApiData ChannelToken where-  toQueryParam (ChannelToken t) = "Bearer " <> t+  toHeader (ChannelToken t)     = encodeUtf8 $ "Bearer " <> t+  toQueryParam (ChannelToken t) = t  instance ToForm ChannelToken where   toForm (ChannelToken t) = [ ("access_token", t) ] -newtype ChannelSecret = ChannelSecret-  { unChannelSecret :: B.ByteString }+newtype ChannelSecret = ChannelSecret { unChannelSecret :: B.ByteString }  instance IsString ChannelSecret where   fromString s = ChannelSecret (B.pack s)@@ -79,6 +86,15 @@ instance ToHttpApiData ChannelSecret where   toQueryParam = decodeUtf8 . unChannelSecret +newtype ChannelId = ChannelId { unChannelId :: Text }+  deriving (Eq, Show, Generic)++instance IsString ChannelId where+  fromString s = ChannelId (fromString s)++instance ToHttpApiData ChannelId where+  toQueryParam (ChannelId t) = t+ data ChatType = User | Group | Room  -- | ID of a chat user, group or room@@ -99,6 +115,15 @@ instance ToJSON (Id a) where   toJSON = String . toQueryParam +instance IsString (Id User) where+  fromString s = UserId (fromString s)++instance IsString (Id Group) where+  fromString s = GroupId (fromString s)++instance IsString (Id Room) where+  fromString s = RoomId (fromString s)+ instance FromJSON (Id User) where   parseJSON = withText "Id User" $ return . UserId @@ -117,31 +142,31 @@ instance FromJSON URL  data Message =-    Text     { text       :: Text-             , quickReply :: Maybe QuickReply-             }-  | Sticker  { packageId  :: Text-             , stickerId  :: Text-             , quickReply :: Maybe QuickReply-             }-  | Image    { originalContentUrl :: URL-             , previewImageUrl    :: URL-             , quickReply         :: Maybe QuickReply-             }-  | Video    { originalContentUrl :: URL-             , previewImageUrl    :: URL-             , quickReply         :: Maybe QuickReply-             }-  | Audio    { originalContentUrl :: URL-             , duration           :: Int-             , quickReply         :: Maybe QuickReply-             }-  | Location { title      :: Text-             , address    :: Text-             , latitude   :: Double-             , longitude  :: Double-             , quickReply :: Maybe QuickReply-             }+    MessageText     { text       :: Text+                    , quickReply :: Maybe QuickReply+                    }+  | MessageSticker  { packageId  :: Text+                    , stickerId  :: Text+                    , quickReply :: Maybe QuickReply+                    }+  | MessageImage    { originalContentUrl :: URL+                    , previewImageUrl    :: URL+                    , quickReply         :: Maybe QuickReply+                    }+  | MessageVideo    { originalContentUrl :: URL+                    , previewImageUrl    :: URL+                    , quickReply         :: Maybe QuickReply+                    }+  | MessageAudio    { originalContentUrl :: URL+                    , duration           :: Int+                    , quickReply         :: Maybe QuickReply+                    }+  | MessageLocation { title      :: Text+                    , address    :: Text+                    , latitude   :: Double+                    , longitude  :: Double+                    , quickReply :: Maybe QuickReply+                    }   deriving (Eq, Show, Generic)  instance ToJSON Message where@@ -153,7 +178,7 @@     { tagFieldName      = "type"     , contentsFieldName = undefined     }-  , constructorTagModifier = fmap toLower+  , constructorTagModifier = fmap toLower . drop 7   , omitNothingFields      = True   } @@ -163,7 +188,7 @@   , pictureUrl    :: URL   , statusMessage :: Maybe Text   }-  deriving (Show, Generic)+  deriving (Eq, Show, Generic)  instance FromJSON Profile @@ -207,32 +232,24 @@  instance ToJSON MulticastMessageBody -data QuickReply = QuickReply+newtype QuickReply = QuickReply   { items :: [QuickReplyButton] }   deriving (Eq, Show, Generic)  instance ToJSON QuickReply -data QuickReplyButton =-    Action { imageUrl :: Maybe URL-           , action   :: Action-           }-  deriving (Eq, Show, Generic)--quickReplyButtonJSONOptions :: Options-quickReplyButtonJSONOptions = defaultOptions-  { sumEncoding            = TaggedObject-    { tagFieldName      = "type"-    , contentsFieldName = undefined-    }-  , constructorTagModifier = fmap toLower-  , omitNothingFields      = True-  , tagSingleConstructors  = True+data QuickReplyButton = QuickReplyButton+  { imageUrl :: Maybe URL+  , action   :: Action   }+  deriving (Eq, Show)  instance ToJSON QuickReplyButton where-  toJSON = genericToJSON quickReplyButtonJSONOptions-+  toJSON QuickReplyButton{..} = object+    [ "type"     .= pack "action"+    , "imageUrl" .= imageUrl+    , "action"   .= action+    ]  data Action =     ActionPostback   { label        :: Text@@ -242,8 +259,8 @@   | ActionMessage    { label :: Text                      , text  :: Text                      }-  | ActionURI        { label :: Text-                     , uri   :: Text+  | ActionUri        { label :: Text+                     , uri   :: URL                      }   | ActionCamera     { label :: Text                      }@@ -262,16 +279,11 @@     { tagFieldName      = "type"     , contentsFieldName = undefined     }-  , constructorTagModifier = (\(x : xs) -> toLower x : xs) . drop 6+  , constructorTagModifier = drop 6 >>> \(x:xs) -> toLower x : xs   , omitNothingFields      = True-  , fieldLabelModifier     = \orig ->-      case L.stripPrefix "postback" orig of-        Just s  -> fmap toLower s-        Nothing -> orig+  , fieldLabelModifier     = \x -> maybe x (fmap toLower) $ L.stripPrefix "postback" x   } -type ChannelId = Id User- data ClientCredentials = ClientCredentials   { clientId     :: ChannelId   , clientSecret :: ChannelSecret@@ -292,3 +304,22 @@ instance FromJSON ShortLivedChannelToken where   parseJSON = genericParseJSON defaultOptions     { fieldLabelModifier = camelTo2 '_' }++newtype LineDate = LineDate { unLineDate :: Day } deriving (Eq)++instance Show LineDate where+  show = formatTime defaultTimeLocale "%Y%m%d" . unLineDate++instance ToHttpApiData LineDate where+  toQueryParam = T.pack . show++data MessageCount = MessageCount+  { count  :: Int+  , status :: String+  } deriving (Eq, Show)++instance FromJSON MessageCount where+  parseJSON = withObject "MessageCount" $ \o -> do+    count  <- o .:  "success"+    status <- o .:  "status"+    return $ MessageCount{..}

@@ -32,6 +32,7 @@   ) where +import           Control.Arrow         ((>>>)) import           Data.Aeson import           Data.Aeson.Types import           Data.Char@@ -112,44 +113,43 @@   deriving (Eq, Show, Generic)  instance FromJSON Event where-  parseJSON = genericParseJSON $-    defaultOptions { sumEncoding            = TaggedObject-                     { tagFieldName      = "type"-                     , contentsFieldName = undefined-                     }-                   , constructorTagModifier = (\(x : xs) -> toLower x : xs) . drop 5-                   }-+  parseJSON = genericParseJSON defaultOptions+    { sumEncoding = TaggedObject+      { tagFieldName      = "type"+      , contentsFieldName = undefined+      }+    , constructorTagModifier = drop 5 >>> \(x:xs) -> toLower x : xs+    }  data Message =-    Text     { messageId :: MessageId-             , text      :: Text-             }-  | Image    { messageId       :: MessageId-             , contentProvider :: ContentProvider-             }-  | Video    { messageId       :: MessageId-             , duration        :: Int-             , contentProvider :: ContentProvider-             }-  | Audio    { messageId       :: MessageId-             , duration        :: Int-             , contentProvider :: ContentProvider-             }-  | File     { messageId :: MessageId-             , fileSize  :: Int-             , fileName  :: Text-             }-  | Location { messageId :: MessageId-             , title     :: Text-             , address   :: Text-             , latitude  :: Double-             , longitude :: Double-             }-  | Sticker  { messageId :: MessageId-             , packageId :: Text-             , stickerId :: Text-             }+    MessageText     { messageId :: MessageId+                    , text      :: Text+                    }+  | MessageImage    { messageId       :: MessageId+                    , contentProvider :: ContentProvider+                    }+  | MessageVideo    { messageId       :: MessageId+                    , duration        :: Int+                    , contentProvider :: ContentProvider+                    }+  | MessageAudio    { messageId       :: MessageId+                    , duration        :: Int+                    , contentProvider :: ContentProvider+                    }+  | MessageFile     { messageId :: MessageId+                    , fileSize  :: Int+                    , fileName  :: Text+                    }+  | MessageLocation { messageId :: MessageId+                    , title     :: Text+                    , address   :: Text+                    , latitude  :: Double+                    , longitude :: Double+                    }+  | MessageSticker  { messageId :: MessageId+                    , packageId :: Text+                    , stickerId :: Text+                    }   deriving (Eq, Show, Generic)  messageJSONOptions :: Options@@ -158,17 +158,13 @@     { tagFieldName      = "type"     , contentsFieldName = undefined     }-  , constructorTagModifier = fmap toLower-  , fieldLabelModifier     = \orig ->-      case L.stripPrefix "message" orig of-        Just s  -> fmap toLower s-        Nothing -> orig+  , constructorTagModifier = fmap toLower . drop 7+  , fieldLabelModifier     = \x -> maybe x (fmap toLower) $ L.stripPrefix "message" x   , omitNothingFields = True   }  instance FromJSON Message where   parseJSON = genericParseJSON messageJSONOptions-  data ContentProvider = ContentProvider   { originalContentUrl :: Maybe URL

@@ -0,0 +1,83 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE TypeFamilies      #-}+{-# LANGUAGE TypeOperators     #-}++module Line.Bot.ClientSpec (spec) where++import           Control.Arrow                    (left)+import           Control.Monad.Trans.Reader       (runReaderT)+import           Data.Aeson                       (Value)+import           Data.Aeson.QQ+import           Data.ByteString                  as B (stripPrefix)+import           Data.Text+import           Data.Text.Encoding+import           Line.Bot.Client                  hiding (runLine)+import           Line.Bot.Client.Auth+import           Line.Bot.Endpoints               (ChannelAuth)+import           Line.Bot.Types+import           Network.HTTP.Client              (defaultManagerSettings,+                                                   newManager)+import           Network.HTTP.Types               (hAuthorization)+import           Network.Wai                      (Request, requestHeaders)+import           Network.Wai.Handler.Warp         (Port, withApplication)+import           Servant+import           Servant.Client+import           Servant.Client.Core.Reexport+import           Servant.Server                   (Context (..))+import           Servant.Server.Experimental.Auth (AuthHandler, AuthServerData,+                                                   mkAuthHandler)+import           Test.Hspec+import           Test.Hspec.Expectations.Contrib+import           Test.Hspec.Wai++type instance AuthServerData ChannelAuth = ChannelToken++-- a dummy auth handler that returns the channel access token+authHandler :: AuthHandler Request ChannelToken+authHandler = mkAuthHandler $ \request -> do+  case lookup hAuthorization (requestHeaders request) >>= B.stripPrefix "Bearer " of+    Nothing -> throwError $ err401 { errBody = "Bad" }+    Just t  -> return $ ChannelToken $ decodeUtf8 t++serverContext :: Context '[AuthHandler Request ChannelToken]+serverContext = authHandler :. EmptyContext++type API =+       ChannelAuth :> "v2" :> "bot" :> "profile" :> "1" :> Get '[JSON] Value+  :<|> ChannelAuth :> "v2" :> "bot" :> "group" :> "1" :> "member" :> "1" :> Get '[JSON] Value++testProfile :: Value+testProfile = [aesonQQ|+  {+      displayName: "LINE taro",+      userId: "U4af4980629...",+      pictureUrl: "https://obs.line-apps.com/...",+      statusMessage: "Hello, LINE!"+  }+|]++withPort :: Port -> (ClientEnv -> IO a) -> IO a+withPort port app = do+  manager <- newManager defaultManagerSettings+  app $ mkClientEnv manager $ BaseUrl Http "localhost" port ""++runLine :: Line a -> Port -> IO (Either ServantError a)+runLine comp port = withPort port $ runClientM $ runReaderT comp "fake"++app :: Application+app = serveWithContext (Proxy :: Proxy API) serverContext $+       (\_ -> return testProfile)+  :<|> (\_ -> return testProfile)++spec :: Spec+spec = describe "Line client" $ do+  it "should return user profile" $ do+    withApplication (pure app) $ \port -> do+      runLine (getProfile "1") port >>= \x -> x `shouldSatisfy` isRight++  it "should return group user profile" $ do+    withApplication (pure app) $ \port -> do+      runLine (getGroupMemberProfile "1" "1") port >>= \x -> x `shouldSatisfy` isRight

@@ -0,0 +1,89 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE TypeOperators     #-}++module Line.Bot.WebhookSpec (spec) where++import qualified Crypto.Hash.SHA256        as SHA256+import           Data.Aeson                (Value, encode)+import           Data.Aeson.QQ+import           Data.Aeson.Types          (emptyObject)+import qualified Data.ByteString.Base64    as Base64+import           Line.Bot.Types            (ChannelSecret (..))+import           Line.Bot.Webhook          (Webhook)+import           Line.Bot.Webhook.Events   (Events)+import           Network.HTTP.Types        (HeaderName, hContentType)+import           Network.HTTP.Types.Method+import           Network.HTTP.Types.Status+import           Servant+import           Servant.Server            (Context ((:.), EmptyContext))+import           Test.Hspec                hiding (context)+import           Test.Hspec.Wai++hSignature :: HeaderName+hSignature = "X-Line-Signature"++secret :: ChannelSecret+secret = "shhhh"++context :: Context (ChannelSecret ': '[])+context = secret :. EmptyContext++app :: Application+app = serveWithContext (Proxy :: Proxy Webhook) context webhook++webhook :: Server Webhook+webhook = handleEvents++handleEvents :: Events -> Handler NoContent+handleEvents _ = return NoContent++testBody :: Value+testBody = [aesonQQ|+  {+    destination: "xxxxxxxxxx",+    events: [+      {+        replyToken: "8cf9239d56244f4197887e939187e19e",+        type: "follow",+        timestamp: 1462629479859,+        source: {+          type: "user",+          userId: "U4af4980629..."+        }+      }+    ]+  }+|]++spec :: Spec+spec = with (pure app) $ do+  describe "Webhook server" $ do++    it "should return 200 with a signed request" $ do+      let body    = encode testBody+          digest  = Base64.encode $ SHA256.hmaclazy (unChannelSecret secret) body+          headers = [(hContentType, "application/json"), (hSignature, digest)]++      request methodPost "/" headers body `shouldRespondWith` 200++    it "should return 400 for an invalid body" $ do+      let body    = encode emptyObject+          digest  = Base64.encode $ SHA256.hmaclazy (unChannelSecret secret) body+          headers = [(hContentType, "application/json"), (hSignature, digest)]++      request methodPost "/" headers body `shouldRespondWith` 400++    it "should return 401 for requests missing the signature header" $ do+      let body    = encode testBody+          headers = [(hContentType, "application/json")]++      request methodPost "/" headers body `shouldRespondWith` 401++    it "should return 401 when secret is incorrect" $ do+      let body    = encode testBody+          digest  = Base64.encode $ SHA256.hmaclazy "incorrect" body+          headers = [(hContentType, "application/json"), (hSignature, digest)]++      request methodPost "/" headers body `shouldRespondWith` 401

@@ -1,20 +1,1 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE OverloadedStrings #-}-module Main (main) where--import Lib (app)-import Test.Hspec-import Test.Hspec.Wai-import Test.Hspec.Wai.JSON--main :: IO ()-main = hspec spec--spec :: Spec-spec = with (return app) $ do-    describe "GET /users" $ do-        it "responds with 200" $ do-            get "/users" `shouldRespondWith` 200-        it "responds with [User]" $ do-            let users = "[{\"userId\":1,\"userFirstName\":\"Isaac\",\"userLastName\":\"Newton\"},{\"userId\":2,\"userFirstName\":\"Albert\",\"userLastName\":\"Einstein\"}]"-            get "/users" `shouldRespondWith` users+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}