1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE NoMonomorphismRestriction #-}
3 {-# LANGUAGE StrictData #-}
4 {-# LANGUAGE TypeApplications #-}
5 {-# LANGUAGE TypeFamilies #-}
6 {-# LANGUAGE TypeOperators #-}
7 {-# OPTIONS_GHC -fno-warn-orphans #-}
10 import Control.Applicative (Applicative(..))
11 import Control.Monad (Monad(..))
13 import Data.Either (Either(..))
14 import Data.Function (($), (.))
15 import Data.Functor ((<$>))
17 import Data.Maybe (Maybe(..))
18 import Data.Semigroup (Semigroup(..))
19 import Data.String (IsString(..))
21 import Prelude (error, (+), (*))
22 import Text.Read (readMaybe)
23 import Text.Show (Show(..))
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.Types as HTTP
32 import qualified Network.URI as URI
33 import qualified Network.Wai.Handler.Warp as Warp
34 import qualified Web.HttpApiData as Web
35 import Test.Hspec.Wai (get, matchStatus, post, shouldRespondWith, with)
38 -- import Test.Tasty.HUnit
42 import Test.Tasty.Hspec
49 | API0_Time Time.ZonedTime
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
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
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
70 -- cli0_get :!: cli0_post = command api0
74 <.> capture @Time.TimeZone "timezone"
75 <.> response @PlainText @TL.Text HTTP.methodGet
78 <.> response @PlainText @TL.Text HTTP.methodGet
82 <.> response @PlainText @TL.Text HTTP.methodGet
86 <.> response @PlainText @Int HTTP.methodGet
90 <.> ( response @PlainText @TL.Text HTTP.methodHead
91 <!> response @PlainText @TL.Text HTTP.methodGet
93 instance MimeSerialize PlainText () where
94 mimeSerialize _mt = fromString . show
95 instance MimeUnserialize PlainText () where
96 mimeUnserialize _mt s =
99 _ -> Left "cannot parse ()"
101 instance MimeSerialize PlainText Int where
102 mimeSerialize _mt = BSL.fromStrict . Text.encodeUtf8 . Text.pack . show
103 instance MimeUnserialize PlainText Int where
104 mimeUnserialize _mt s =
105 case readMaybe $ TL.unpack $ TL.decodeUtf8 s of
107 _ -> Left "cannot parse Int"
118 rou1 = routerAPI api1 $
125 route_time tz (RouterResponseArg respond) =
126 RouterResponse $ \_req res -> do
127 time <- Time.utcToZonedTime tz <$> Time.getCurrentTime
128 res $ respond status200 [] $
129 TL.pack $ show time <> "\n"
131 route_date (RouterResponseArg respond) =
132 RouterResponse $ \_req res -> do
133 date <- Time.utctDay <$> Time.getCurrentTime
134 res $ respond status200 [] $
135 TL.pack $ show date <> "\n"
137 route_echo path (RouterResponseArg respond) =
138 RouterResponse $ \_req res -> do
139 res $ respond status200 [] $ TL.pack $ show path <> "\n"
141 route_succ n (RouterResponseArg respond) =
142 RouterResponse $ \_req res -> do
143 res $ respond status200 [] $ n+1
145 route_info = route_head :!: route_get
147 route_head (RouterResponseArg respond) =
148 RouterResponse $ \req res -> do
149 res $ respond (HTTP.mkStatus 201 "") [] $ TL.pack $ show req <> "\n"
151 route_get (RouterResponseArg respond) =
152 RouterResponse $ \req res -> do
153 res $ respond status200 [] $ TL.pack $ show req <> "\n"
156 srv1 = Warp.run 8080 rou1
161 it "allows running arbitrary monads" $ do
162 get "/date" `shouldRespondWith` 200
166 <.> response @PlainText @TL.Text HTTP.methodGet
169 <.> response @PlainText @TL.Text HTTP.methodGet
171 rou2 = routerAPI api2 $
175 route_time (RouterResponseArg respond) =
176 RouterResponse $ \_req res -> do
177 time <- Time.getCurrentTime
178 res $ respond status200 [] $
179 TL.pack $ show time <> "\n"
181 route_date (RouterResponseArg respond) =
182 RouterResponse $ \_req res -> do
183 date <- Time.utctDay <$> Time.getCurrentTime
184 res $ respond status200 [] $
185 TL.pack $ show date <> "\n"
188 srv2 = Warp.run 8080 rou2