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 instance MimeSerialize () PlainText where
  86         mimeSerialize _mt = fromString . show
  87 instance MimeUnserialize () PlainText where
  88         mimeUnserialize _mt s =
  89                 case s of
  90                  "()" -> Right ()
  91                  _ -> Left "cannot parse ()"
  92
  93 instance MimeSerialize Int PlainText where
  94         mimeSerialize _mt = BSL.fromStrict . Text.encodeUtf8 . Text.pack . show
  95 instance MimeUnserialize Int PlainText where
  96         mimeUnserialize _mt s =
  97                 case readMaybe $ TL.unpack $ TL.decodeUtf8 s of
  98                  Just n -> Right n
  99                  _ -> Left "cannot parse Int"
 100
 101 lay1 = layout api1
 102
 103 (api1_time :!:
 104  api1_date :!:
 105  api1_echo :!:
 106  api1_succ :!:
 107  (api1_info_head :!:
 108   api1_info_get)
 109  ) = client api1
 110
 111 srv1 = server api1 $
 112         route_time :!:
 113         route_date :!:
 114         route_echo :!:
 115         route_succ :!:
 116         route_info
 117         where
 118         route_time tz (ServerResponseArg respond) =
 119                 ServerResponse $ \_req res -> do
 120                         time <- Time.utcToZonedTime tz <$> Time.getCurrentTime
 121                         res $ respond status200 [] $
 122                                 TL.pack $ show time <> "\n"
 123
 124         route_date (ServerResponseArg respond) =
 125                 ServerResponse $ \_req res -> do
 126                         date <- Time.utctDay <$> Time.getCurrentTime
 127                         res $ respond status200 [] $
 128                                 TL.pack $ show date <> "\n"
 129
 130         route_echo path (ServerResponseArg respond) =
 131                 ServerResponse $ \_req res -> do
 132                         res $ respond status200 [] $ TL.pack $ show path <> "\n"
 133
 134         route_succ n (ServerResponseArg respond) =
 135                 ServerResponse $ \_req res -> do
 136                         res $ respond status200 [] $ n+1
 137
 138         route_info = route_head :!: route_get
 139                 where
 140                 route_head (ServerResponseArg respond) =
 141                         ServerResponse $ \req res -> do
 142                                 res $ respond (HTTP.mkStatus 201 "") [] $ TL.pack $ show req <> "\n"
 143
 144                 route_get (ServerResponseArg respond) =
 145                         ServerResponse $ \req res -> do
 146                                 res $ respond status200 [] $ TL.pack $ show req <> "\n"
 147
 148 warp1 :: IO ()
 149 warp1 = Warp.run 8080 srv1
 150
 151 api2 = "ti"</>"me" </> get @TL.Text @PlainText
 152    <!> "auth"      </> basicAuth @User "realm" ()
 153                    <.> get @TL.Text @PlainText
 154    <!> "da"</>"te" </> get @TL.Text @PlainText
 155
 156 data User = User
 157  deriving (Show)
 158 instance ServerBasicAuthable context User where
 159         serverBasicAuthable context user pass =
 160                 return $ BasicAuth_Authorized User
 161
 162 srv2 = server api2 $
 163             route_time
 164         :!: route_auth
 165         :!: route_date
 166         where
 167         route_time (ServerResponseArg respond) =
 168                 ServerResponse $ \_req res -> do
 169                         time <- Time.getCurrentTime
 170                         res $ respond status200 [] $
 171                                 TL.pack $ show time <> "\n"
 172
 173         route_date (ServerResponseArg respond) =
 174                 ServerResponse $ \_req res -> do
 175                         date <- Time.utctDay <$> Time.getCurrentTime
 176                         res $ respond status200 [] $
 177                                 TL.pack $ show date <> "\n"
 178
 179         route_auth User (ServerResponseArg respond) =
 180                         ServerResponse $ \_req res -> do
 181                                 res $ respond status200 [] $
 182                                         TL.pack $ show User <> "\n"
 183
 184 warp2 :: IO ()
 185 warp2 = Warp.run 8080 srv2
 186
 187 hspec =
 188         testSpecs $
 189         Wai.with (return srv2) $ do
 190                 it "respond with success" $ do
 191                         Wai.get "/da/te"
 192                          `Wai.shouldRespondWith` 200
 193                 it "checks Accept header" $ do
 194                         Wai.request HTTP.methodGet "/da/te"
 195                          [ (HTTP.hAccept, Media.renderHeader $ mimeType $ Proxy @OctetStream)
 196                          ] ""
 197                          `Wai.shouldRespondWith` 406
 198