test/Hspec/API.hs

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