test/Hspec/API.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE NoMonomorphismRestriction #-}
   3 {-# LANGUAGE StrictData #-}
   4 {-# LANGUAGE TypeApplications #-}
   5 {-# LANGUAGE TypeFamilies #-}
   6 {-# LANGUAGE TypeOperators #-}
   7 {-# OPTIONS_GHC -fno-warn-orphans #-}
   8 module Hspec.API where
   9
  10 import Control.Applicative (Applicative(..))
  11 import Control.Monad (Monad(..))
  12 import Data.Bool
  13 import Data.Either (Either(..))
  14 import Data.Function (($), (.))
  15 import Data.Functor ((<$>))
  16 import Data.Int (Int)
  17 import Data.Maybe (Maybe(..))
  18 import Data.Semigroup (Semigroup(..))
  19 import Data.String (IsString(..))
  20 import System.IO (IO)
  21 import Prelude (error, (+), (*))
  22 import Text.Read (readMaybe)
  23 import Text.Show (Show(..))
  24 import qualified Data.ByteString.Lazy as BSL
  25 import qualified Data.Text as Text
  26 import qualified Data.Text.Encoding as Text
  27 import qualified Data.Text.Lazy as TL
  28 import qualified Data.Text.Lazy.Encoding as TL
  29 import qualified Data.Time as Time
  30 import qualified Network.HTTP.Client as Client
  31 import qualified Network.HTTP.Types as HTTP
  32 import qualified Network.URI as URI
  33 import qualified Network.Wai.Handler.Warp as Warp
  34 import qualified Web.HttpApiData as Web
  35 import           Test.Hspec.Wai (get, matchStatus, post, shouldRespondWith, with)
  36
  37 -- import Test.Hspec
  38 -- import Test.Tasty.HUnit
  39 import Test.Hspec
  40 import Test.Hspec.Wai
  41 import Test.Tasty
  42 import Test.Tasty.Hspec
  43
  44 import Symantic.HTTP
  45
  46 -- * Type 'API0'
  47 data API0
  48  =   API0_Date Time.Day
  49  |   API0_Time Time.ZonedTime
  50  |   API0_Reset Bool
  51  deriving (Show)
  52 instance IsString Time.TimeZone where
  53         fromString s = case s of
  54          "CET"  -> Time.TimeZone (1*60) False "CET"
  55          "CEST" -> Time.TimeZone (2*60) False "CEST"
  56          _ -> error "unknown TimeZone"
  57 instance Web.FromHttpApiData Time.TimeZone where
  58         parseUrlPiece = \case
  59          "CET"  -> Right $ Time.TimeZone (1*60) True  "CET"
  60          "CEST" -> Right $ Time.TimeZone (2*60) False "CEST"
  61          _ -> Left "unknown TimeZone"
  62 instance Web.ToHttpApiData Time.TimeZone where
  63         toUrlPiece (Time.TimeZone _s _b n) = Text.pack n
  64
  65 manager :: IO Client.Manager
  66 manager = Client.newManager Client.defaultManagerSettings
  67 Just baseURI = URI.parseURI "http://localhost:8080"
  68 cliEnv = clientEnv <$> manager <*> pure baseURI
  69
  70 -- cli0_get :!: cli0_post = command api0
  71
  72 api1
  73  =   segment "time"
  74  <.> capture @Time.TimeZone "timezone"
  75  <.> response @PlainText @TL.Text HTTP.methodGet
  76
  77  <!> segment "date"
  78  <.> response @PlainText @TL.Text HTTP.methodGet
  79
  80  <!> segment "echo"
  81  <.> captureAll
  82  <.> response @PlainText @TL.Text HTTP.methodGet
  83
  84  <!> segment "succ"
  85  <.> capture @Int "n"
  86  <.> response @PlainText @Int HTTP.methodGet
  87
  88  <!>
  89  segment "info"
  90  <.> (  response @PlainText @TL.Text HTTP.methodHead
  91     <!> response @PlainText @TL.Text HTTP.methodGet
  92      )
  93 instance MimeSerialize PlainText () where
  94         mimeSerialize _mt = fromString . show
  95 instance MimeUnserialize PlainText () where
  96         mimeUnserialize _mt s =
  97                 case s of
  98                  "()" -> Right ()
  99                  _ -> Left "cannot parse ()"
 100
 101 instance MimeSerialize PlainText Int where
 102         mimeSerialize _mt = BSL.fromStrict . Text.encodeUtf8 . Text.pack . show
 103 instance MimeUnserialize PlainText Int where
 104         mimeUnserialize _mt s =
 105                 case readMaybe $ TL.unpack $ TL.decodeUtf8 s of
 106                  Just n -> Right n
 107                  _ -> Left "cannot parse Int"
 108
 109 lay1 = layout api1
 110
 111 (api1_time :!:
 112  api1_date :!:
 113  api1_echo :!:
 114  api1_succ :!:
 115  api1_info
 116  ) = runCommand api1
 117
 118 rou1 = routerAPI api1 $
 119         route_time :!:
 120         route_date :!:
 121         route_echo :!:
 122         route_succ :!:
 123         route_info
 124         where
 125         route_time tz (RouterResponseArg respond) =
 126                 RouterResponse $ \_req res -> do
 127                         time <- Time.utcToZonedTime tz <$> Time.getCurrentTime
 128                         res $ respond status200 [] $
 129                                 TL.pack $ show time <> "\n"
 130
 131         route_date (RouterResponseArg respond) =
 132                 RouterResponse $ \_req res -> do
 133                         date <- Time.utctDay <$> Time.getCurrentTime
 134                         res $ respond status200 [] $
 135                                 TL.pack $ show date <> "\n"
 136
 137         route_echo path (RouterResponseArg respond) =
 138                 RouterResponse $ \_req res -> do
 139                         res $ respond status200 [] $ TL.pack $ show path <> "\n"
 140
 141         route_succ n (RouterResponseArg respond) =
 142                 RouterResponse $ \_req res -> do
 143                         res $ respond status200 [] $ n+1
 144
 145         route_info = route_head :!: route_get
 146                 where
 147                 route_head (RouterResponseArg respond) =
 148                         RouterResponse $ \req res -> do
 149                                 res $ respond (HTTP.mkStatus 201 "") [] $ TL.pack $ show req <> "\n"
 150
 151                 route_get (RouterResponseArg respond) =
 152                         RouterResponse $ \req res -> do
 153                                 res $ respond status200 [] $ TL.pack $ show req <> "\n"
 154
 155 srv1 :: IO ()
 156 srv1 = Warp.run 8080 rou1
 157
 158 hspec =
 159         testSpecs $
 160         with (return rou1) $
 161                 it "allows running arbitrary monads" $ do
 162                         get "/date" `shouldRespondWith` 200
 163
 164 api2
 165  =   segment "time"
 166  <.> response @PlainText @TL.Text HTTP.methodGet
 167
 168  <!> segment "date"
 169  <.> response @PlainText @TL.Text HTTP.methodGet
 170
 171 rou2 = routerAPI api2 $
 172         route_time :!:
 173         route_date
 174         where
 175         route_time (RouterResponseArg respond) =
 176                 RouterResponse $ \_req res -> do
 177                         time <- Time.getCurrentTime
 178                         res $ respond status200 [] $
 179                                 TL.pack $ show time <> "\n"
 180
 181         route_date (RouterResponseArg respond) =
 182                 RouterResponse $ \_req res -> do
 183                         date <- Time.utctDay <$> Time.getCurrentTime
 184                         res $ respond status200 [] $
 185                                 TL.pack $ show date <> "\n"
 186
 187 srv2 :: IO ()
 188 srv2 = Warp.run 8080 rou2