1 {-# LANGUAGE NoMonomorphismRestriction #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE StrictData #-}
4 {-# OPTIONS_GHC -fno-warn-orphans #-}
7 import Control.Applicative (Applicative(..))
8 import Control.Monad (Monad(..))
9 import Control.Monad.Trans.Class (MonadTrans(..))
11 import Data.Either (Either(..))
12 import Data.Function (($), (.))
13 import Data.Functor ((<$>))
15 import Data.Maybe (Maybe(..))
16 import Data.Proxy (Proxy(..))
17 import Data.Semigroup (Semigroup(..))
18 import Data.String (IsString(..))
19 import Prelude (error, (+), (*))
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
42 import Test.Tasty.Hspec
45 import Symantic.HTTP.Utils (liftIO)
50 | API0_Time Time.ZonedTime
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
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
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
72 = "time" </> capture @Time.TimeZone "timezone"
73 <.> get @TL.Text @'[PlainText]
75 <!> "date" </> get @TL.Text @'[PlainText]
77 <!> "echo" </> captureAll
78 <.> get @TL.Text @'[PlainText]
80 <!> "succ" </> capture @Int "n"
81 <.> get @Int @'[PlainText]
83 <!> "info" </> ( post @TL.Text @'[PlainText]
84 <!> get @TL.Text @'[PlainText]
106 time <- liftIO $ Time.utcToZonedTime tz <$> Time.getCurrentTime
107 return $ TL.pack $ show (i, time) <> "\n"
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"
115 route_echo path = return $ TL.pack $ show path <> "\n"
117 route_succ n = return $ n+1
119 route_info = route_post :!: route_get
122 req :: Wai.Request <- MC.ask
123 return $ TL.pack $ show req <> "\n"
126 req :: Wai.Request <- MC.ask
127 return $ TL.pack $ show req <> "\n"
130 warp1 = Warp.run 8080 srv1
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]
139 instance ServerBasicAuth User where
140 serverBasicAuth user pass =
141 return $ BasicAuth_Authorized User
150 time <- liftIO $ Time.getCurrentTime
151 return $ TL.pack $ show date <> "\n" <> show time <> "\n"
154 date <- liftIO $ Time.utctDay <$> Time.getCurrentTime
155 return $ TL.pack $ show date <> "\n"
158 return $ TL.pack $ show User <> "\n"
161 warp2 = Warp.run 8080 srv2
163 hspec :: IO [TestTree]
166 Wai.with (return srv2) $ do
167 it "respond with success" $ do
169 `Wai.shouldRespondWith` 200
170 it "checks Accept header" $ do
171 Wai.request HTTP.methodGet "/da/te"
172 [ (HTTP.hAccept, Media.renderHeader $ mediaType @OctetStream)
174 `Wai.shouldRespondWith` 406