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 lay1 = layout api1
  88
  89 (cli1_time :!:
  90  cli1_date :!:
  91  cli1_echo :!:
  92  cli1_succ :!:
  93  (cli1_info_head :!:
  94   cli1_info_get)
  95  ) = client api1
  96
  97 srv1 = server api1 $
  98         route_time :!:
  99         route_date :!:
 100         route_echo :!:
 101         route_succ :!:
 102         route_info
 103         where
 104         route_time tz = do
 105                 i <- route_succ 0
 106                 time <- liftIO $ Time.utcToZonedTime tz <$> Time.getCurrentTime
 107                 return $ TL.pack $ show (i, time) <> "\n"
 108
 109         route_date = do
 110                 date <- liftIO $ Time.utctDay <$> Time.getCurrentTime
 111                 -- C.shiftT $ \k -> return $ Wai.responseLBS HTTP.status400 [] ""
 112                 MC.tell HTTP.status200
 113                 return $ TL.pack $ show date <> "\n"
 114
 115         route_echo path = return $ TL.pack $ show path <> "\n"
 116
 117         route_succ n = return $ n+1
 118
 119         route_info = route_post :!: route_get
 120                 where
 121                 route_post = do
 122                         req :: Wai.Request <- MC.ask
 123                         return $ TL.pack $ show req <> "\n"
 124
 125                 route_get = do
 126                         req :: Wai.Request <- MC.ask
 127                         return $ TL.pack $ show req <> "\n"
 128
 129 warp1 :: IO ()
 130 warp1 = Warp.run 8080 srv1
 131
 132 api2 = "ti"</>"me" </> get @TL.Text @'[PlainText]
 133    <!> "auth"      </> basicAuth @User "realm"
 134                    <.> get @TL.Text @'[PlainText]
 135    <!> "da"</>"te" </> get @TL.Text @'[PlainText]
 136
 137 data User = User
 138  deriving (Show)
 139 instance ServerBasicAuth User where
 140         serverBasicAuth user pass =
 141                 return $ BasicAuth_Authorized User
 142
 143 srv2 = server api2 $
 144             route_time
 145         :!: route_auth
 146         :!: route_date
 147         where
 148         route_time = do
 149                 date <- route_date
 150                 time <- liftIO $ Time.getCurrentTime
 151                 return $ TL.pack $ show date <> "\n" <> show time <> "\n"
 152
 153         route_date = do
 154                 date <- liftIO $ Time.utctDay <$> Time.getCurrentTime
 155                 return $ TL.pack $ show date <> "\n"
 156
 157         route_auth User = do
 158                 return $ TL.pack $ show User <> "\n"
 159
 160 warp2 :: IO ()
 161 warp2 = Warp.run 8080 srv2
 162
 163 hspec :: IO [TestTree]
 164 hspec =
 165         testSpecs $
 166         Wai.with (return srv2) $ do
 167                 it "respond with success" $ do
 168                         Wai.get "/da/te"
 169                          `Wai.shouldRespondWith` 200
 170                 it "checks Accept header" $ do
 171                         Wai.request HTTP.methodGet "/da/te"
 172                          [ (HTTP.hAccept, Media.renderHeader $ mediaType @OctetStream)
 173                          ] ""
 174                          `Wai.shouldRespondWith` 406
 175