test/Hspec/API.hs

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