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 Control.Monad.Trans.Class (MonadTrans(..))
  10 import Data.Bool
  11 import Data.Either (Either(..))
  12 import Data.Function (($), (.))
  13 import Data.Functor ((<$>))
  14 import Data.Int (Int)
  15 import Data.Maybe (Maybe(..))
  16 import Data.Proxy (Proxy(..))
  17 import Data.Semigroup (Semigroup(..))
  18 import Data.String (IsString(..))
  19 import Prelude (error, (+), (*))
  20 import System.IO (IO)
  21 import Text.Read (readMaybe)
  22 import Text.Show (Show(..))
  23 import qualified Control.Monad.Trans.Cont as C
  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.Media as Media
  32 import qualified Network.HTTP.Types as HTTP
  33 import qualified Network.URI as URI
  34 import qualified Network.Wai as Wai
  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 import qualified Control.Monad.Classes as MC
  39
  40 import Test.Hspec
  41 import Test.Tasty
  42 import Test.Tasty.Hspec
  43
  44 import Symantic.HTTP
  45 import Symantic.HTTP.Utils (liftIO)
  46
  47 -- * Type 'API0'
  48 data API0
  49  =   API0_Date Time.Day
  50  |   API0_Time Time.ZonedTime
  51  |   API0_Reset Bool
  52  deriving (Show)
  53 instance IsString Time.TimeZone where
  54         fromString s = case s of
  55          "CET"  -> Time.TimeZone (1*60) False "CET"
  56          "CEST" -> Time.TimeZone (2*60) False "CEST"
  57          _ -> error "unknown TimeZone"
  58 instance Web.FromHttpApiData Time.TimeZone where
  59         parseUrlPiece = \case
  60          "CET"  -> Right $ Time.TimeZone (1*60) True  "CET"
  61          "CEST" -> Right $ Time.TimeZone (2*60) False "CEST"
  62          _ -> Left "unknown TimeZone"
  63 instance Web.ToHttpApiData Time.TimeZone where
  64         toUrlPiece (Time.TimeZone _s _b n) = Text.pack n
  65
  66 manager :: IO Client.Manager
  67 manager = Client.newManager Client.defaultManagerSettings
  68 Just baseURI = URI.parseURI "http://localhost:8080"
  69 cliEnv = clientEnv <$> manager <*> pure baseURI
  70
  71 api1
  72  =   "time" </> capture @Time.TimeZone "timezone"
  73             <.> get @TL.Text @'[PlainText]
  74
  75  <!> "date" </> get @TL.Text @'[PlainText]
  76
  77  <!> "echo" </> captureAll
  78             <.> get @TL.Text @'[PlainText]
  79
  80  <!> "succ" </> capture @Int "n"
  81             <.> get @Int @'[PlainText]
  82
  83  <!> "info" </> (  post @TL.Text @'[PlainText]
  84                <!> get  @TL.Text @'[PlainText]
  85                 )
  86
  87 instance MimeEncodable Int PlainText where
  88         mimeEncode _mt = BSL.fromStrict . Text.encodeUtf8 . Text.pack . show
  89 instance MimeDecodable Int PlainText where
  90         mimeDecode _mt s =
  91                 case readMaybe $ TL.unpack $ TL.decodeUtf8 s of
  92                  Just n -> Right n
  93                  _ -> Left "cannot parse Int"
  94
  95 lay1 = layout api1
  96
  97 (api1_time :!:
  98  api1_date :!:
  99  api1_echo :!:
 100  api1_succ :!:
 101  (api1_info_head :!:
 102   api1_info_get)
 103  ) = client api1
 104
 105 srv1 = server api1 $
 106         route_time :!:
 107         route_date :!:
 108         route_echo :!:
 109         route_succ :!:
 110         route_info
 111         where
 112         route_time tz = do
 113                 i <- route_succ 0
 114                 time <- liftIO $ Time.utcToZonedTime tz <$> Time.getCurrentTime
 115                 return $ TL.pack $ show (i, time) <> "\n"
 116
 117         route_date = do
 118                 date <- liftIO $ Time.utctDay <$> Time.getCurrentTime
 119                 -- C.shiftT $ \k -> return $ Wai.responseLBS status400 [] ""
 120                 MC.tell status200
 121                 return $ TL.pack $ show date <> "\n"
 122
 123         route_echo path = return $ TL.pack $ show path <> "\n"
 124
 125         route_succ n = return $ n+1
 126
 127         route_info = route_post :!: route_get
 128                 where
 129                 route_post = do
 130                         req :: Wai.Request <- MC.ask
 131                         return $ TL.pack $ show req <> "\n"
 132
 133                 route_get = do
 134                         req :: Wai.Request <- MC.ask
 135                         return $ 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 = do
 157                 date <- route_date
 158                 time <- liftIO $ Time.getCurrentTime
 159                 return $ TL.pack $ show date <> "\n" <> show time <> "\n"
 160
 161         route_date = do
 162                 date <- liftIO $ Time.utctDay <$> Time.getCurrentTime
 163                 return $ TL.pack $ show date <> "\n"
 164
 165         route_auth User = do
 166                 return $ TL.pack $ show User <> "\n"
 167
 168 warp2 :: IO ()
 169 warp2 = Warp.run 8080 srv2
 170
 171 hspec =
 172         testSpecs $
 173         Wai.with (return srv2) $ do
 174                 it "respond with success" $ do
 175                         Wai.get "/da/te"
 176                          `Wai.shouldRespondWith` 200
 177                 it "checks Accept header" $ do
 178                         Wai.request HTTP.methodGet "/da/te"
 179                          [ (HTTP.hAccept, Media.renderHeader $ mediaType @OctetStream)
 180                          ] ""
 181                          `Wai.shouldRespondWith` 406
 182