]> Git — Sourcephile - haskell/symantic-http.git/blob - test/Hspec/API.hs
Rename MIME types
[haskell/symantic-http.git] / 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