test/Hspec/API.hs

   1 {-# LANGUAGE NoMonomorphismRestriction #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   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.Proxy (Proxy(..))
  19 import Data.Semigroup (Semigroup(..))
  20 import Data.String (IsString(..))
  21 import Prelude (error, (+), (*))
  22 import System.IO (IO)
  23 import Text.Read (readMaybe)
  24 import Text.Show (Show(..))
  25 import qualified Data.ByteString.Lazy as BSL
  26 import qualified Data.Text as Text
  27 import qualified Data.Text.Encoding as Text
  28 import qualified Data.Text.Lazy as TL
  29 import qualified Data.Text.Lazy.Encoding as TL
  30 import qualified Data.Time as Time
  31 import qualified Network.HTTP.Client as Client
  32 import qualified Network.HTTP.Media as Media
  33 import qualified Network.HTTP.Types as HTTP
  34 import qualified Network.URI as URI
  35 import qualified Network.Wai.Handler.Warp as Warp
  36 import qualified Test.Hspec.Wai as Wai
  37 import qualified Web.HttpApiData as Web
  38
  39 import Test.Hspec
  40 import Test.Tasty
  41 import Test.Tasty.Hspec
  42
  43 import Symantic.HTTP
  44
  45 -- * Type 'API0'
  46 data API0
  47  =   API0_Date Time.Day
  48  |   API0_Time Time.ZonedTime
  49  |   API0_Reset Bool
  50  deriving (Show)
  51 instance IsString Time.TimeZone where
  52         fromString s = case s of
  53          "CET"  -> Time.TimeZone (1*60) False "CET"
  54          "CEST" -> Time.TimeZone (2*60) False "CEST"
  55          _ -> error "unknown TimeZone"
  56 instance Web.FromHttpApiData Time.TimeZone where
  57         parseUrlPiece = \case
  58          "CET"  -> Right $ Time.TimeZone (1*60) True  "CET"
  59          "CEST" -> Right $ Time.TimeZone (2*60) False "CEST"
  60          _ -> Left "unknown TimeZone"
  61 instance Web.ToHttpApiData Time.TimeZone where
  62         toUrlPiece (Time.TimeZone _s _b n) = Text.pack n
  63
  64 manager :: IO Client.Manager
  65 manager = Client.newManager Client.defaultManagerSettings
  66 Just baseURI = URI.parseURI "http://localhost:8080"
  67 cliEnv = clientEnv <$> manager <*> pure baseURI
  68
  69 api1
  70  =   "time" </> capture @Time.TimeZone "timezone"
  71             <.> get @TL.Text @PlainText
  72
  73  <!> "date" </> get @TL.Text @PlainText
  74
  75  <!> "echo" </> captureAll
  76             <.> get @TL.Text @PlainText
  77
  78  <!> "succ" </> capture @Int "n"
  79             <.> get @Int @PlainText
  80
  81  <!> "info" </> (  head @TL.Text @PlainText
  82                <!> get  @TL.Text @PlainText
  83                 )
  84 instance MimeSerialize () PlainText where
  85         mimeSerialize _mt = fromString . show
  86 instance MimeUnserialize () PlainText where
  87         mimeUnserialize _mt s =
  88                 case s of
  89                  "()" -> Right ()
  90                  _ -> Left "cannot parse ()"
  91
  92 instance MimeSerialize Int PlainText where
  93         mimeSerialize _mt = BSL.fromStrict . Text.encodeUtf8 . Text.pack . show
  94 instance MimeUnserialize Int PlainText where
  95         mimeUnserialize _mt s =
  96                 case readMaybe $ TL.unpack $ TL.decodeUtf8 s of
  97                  Just n -> Right n
  98                  _ -> Left "cannot parse Int"
  99
 100 lay1 = layout api1
 101
 102 (api1_time :!:
 103  api1_date :!:
 104  api1_echo :!:
 105  api1_succ :!:
 106  (api1_info_head :!:
 107   api1_info_get)
 108  ) = client api1
 109
 110 srv1 = server api1 $
 111         route_time :!:
 112         route_date :!:
 113         route_echo :!:
 114         route_succ :!:
 115         route_info
 116         where
 117         route_time tz (ServerResponseArg respond) =
 118                 ServerResponse $ \_req res -> do
 119                         time <- Time.utcToZonedTime tz <$> Time.getCurrentTime
 120                         res $ respond status200 [] $
 121                                 TL.pack $ show time <> "\n"
 122
 123         route_date (ServerResponseArg respond) =
 124                 ServerResponse $ \_req res -> do
 125                         date <- Time.utctDay <$> Time.getCurrentTime
 126                         res $ respond status200 [] $
 127                                 TL.pack $ show date <> "\n"
 128
 129         route_echo path (ServerResponseArg respond) =
 130                 ServerResponse $ \_req res -> do
 131                         res $ respond status200 [] $ TL.pack $ show path <> "\n"
 132
 133         route_succ n (ServerResponseArg respond) =
 134                 ServerResponse $ \_req res -> do
 135                         res $ respond status200 [] $ n+1
 136
 137         route_info = route_head :!: route_get
 138                 where
 139                 route_head (ServerResponseArg respond) =
 140                         ServerResponse $ \req res -> do
 141                                 res $ respond (HTTP.mkStatus 201 "") [] $ TL.pack $ show req <> "\n"
 142
 143                 route_get (ServerResponseArg respond) =
 144                         ServerResponse $ \req res -> do
 145                                 res $ respond status200 [] $ TL.pack $ show req <> "\n"
 146
 147 warp1 :: IO ()
 148 warp1 = Warp.run 8080 srv1
 149
 150 api2 = "ti"</>"me" </> get @TL.Text @PlainText
 151    <!> "da"</>"te" </> get @TL.Text @PlainText
 152
 153 srv2 = server api2 $
 154         route_time :!:
 155         route_date
 156         where
 157         route_time (ServerResponseArg respond) =
 158                 ServerResponse $ \_req res -> do
 159                         time <- Time.getCurrentTime
 160                         res $ respond status200 [] $
 161                                 TL.pack $ show time <> "\n"
 162
 163         route_date (ServerResponseArg respond) =
 164                 ServerResponse $ \_req res -> do
 165                         date <- Time.utctDay <$> Time.getCurrentTime
 166                         res $ respond status200 [] $
 167                                 TL.pack $ show date <> "\n"
 168
 169 warp2 :: IO ()
 170 warp2 = Warp.run 8080 srv2
 171
 172 hspec =
 173         testSpecs $
 174         Wai.with (return srv2) $ do
 175                 it "respond with success" $ do
 176                         Wai.get "/da/te"
 177                          `Wai.shouldRespondWith` 200
 178                 it "checks Accept header" $ do
 179                         Wai.request HTTP.methodGet "/da/te"
 180                          [ (HTTP.hAccept, Media.renderHeader $ mimeType $ Proxy @OctetStream)
 181                          ] ""
 182                          `Wai.shouldRespondWith` 406
 183