]> Git — Sourcephile - haskell/symantic-http.git/blob - test/Hspec/API.hs
Stop here to drop megaparsec
[haskell/symantic-http.git] / test / Hspec / API.hs
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE NoMonomorphismRestriction #-}
3 {-# LANGUAGE StrictData #-}
4 {-# LANGUAGE TypeApplications #-}
5 {-# LANGUAGE TypeFamilies #-}
6 {-# LANGUAGE TypeOperators #-}
7 {-# OPTIONS_GHC -fno-warn-orphans #-}
8 module Hspec.API where
9
10 import Control.Applicative (Applicative(..))
11 import Control.Monad (Monad(..))
12 import Data.Bool
13 import Data.Either (Either(..))
14 import Data.Function (($), (.))
15 import Data.Functor ((<$>))
16 import Data.Int (Int)
17 import Data.Maybe (Maybe(..))
18 import Data.Semigroup (Semigroup(..))
19 import Data.String (IsString(..))
20 import System.IO (IO)
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)
36
37 -- import Test.Hspec
38 -- import Test.Tasty.HUnit
39 import Test.Hspec
40 import Test.Hspec.Wai
41 import Test.Tasty
42 import Test.Tasty.Hspec
43
44 import Symantic.HTTP
45
46 -- * Type 'API0'
47 data API0
48 = API0_Date Time.Day
49 | API0_Time Time.ZonedTime
50 | API0_Reset Bool
51 deriving (Show)
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
58 parseUrlPiece = \case
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
64
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
69
70 -- cli0_get :!: cli0_post = command api0
71
72 api1
73 = segment "time"
74 <.> capture @Time.TimeZone "timezone"
75 <.> endpoint @TL.Text @PlainText HTTP.methodGet
76
77 <!> segment "date"
78 <.> endpoint @TL.Text @PlainText HTTP.methodGet
79
80 <!> segment "echo"
81 <.> captureAll
82 <.> endpoint @TL.Text @PlainText HTTP.methodGet
83
84 <!> segment "succ"
85 <.> capture @Int "n"
86 <.> endpoint @Int @PlainText HTTP.methodGet
87
88 <!>
89 segment "info"
90 <.> ( endpoint @TL.Text @PlainText HTTP.methodHead
91 <!> endpoint @TL.Text @PlainText HTTP.methodGet
92 )
93 instance MimeSerialize PlainText () where
94 mimeSerialize _mt = fromString . show
95 instance MimeUnserialize PlainText () where
96 mimeUnserialize _mt s =
97 case s of
98 "()" -> Right ()
99 _ -> Left "cannot parse ()"
100
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
106 Just n -> Right n
107 _ -> Left "cannot parse Int"
108
109 lay1 = layout api1
110
111 (api1_time :!:
112 api1_date :!:
113 api1_echo :!:
114 api1_succ :!:
115 api1_info
116 ) = runCommand api1
117
118 rou1 = runRouter api1 $
119 route_time :!:
120 route_date :!:
121 route_echo :!:
122 route_succ :!:
123 route_info
124 where
125 route_time tz (RouterEndpointArg respond) =
126 RouterResponse $ \_req res -> do
127 time <- Time.utcToZonedTime tz <$> Time.getCurrentTime
128 res $ respond status200 [] $
129 TL.pack $ show time <> "\n"
130
131 route_date (RouterEndpointArg respond) =
132 RouterResponse $ \_req res -> do
133 date <- Time.utctDay <$> Time.getCurrentTime
134 res $ respond status200 [] $
135 TL.pack $ show date <> "\n"
136
137 route_echo path (RouterEndpointArg respond) =
138 RouterResponse $ \_req res -> do
139 res $ respond status200 [] $ TL.pack $ show path <> "\n"
140
141 route_succ n (RouterEndpointArg respond) =
142 RouterResponse $ \_req res -> do
143 res $ respond status200 [] $ n+1
144
145 route_info = route_head :!: route_get
146 where
147 route_head (RouterEndpointArg respond) =
148 RouterResponse $ \req res -> do
149 res $ respond (HTTP.mkStatus 201 "") [] $ TL.pack $ show req <> "\n"
150
151 route_get (RouterEndpointArg respond) =
152 RouterResponse $ \req res -> do
153 res $ respond status200 [] $ TL.pack $ show req <> "\n"
154
155 srv1 :: IO ()
156 srv1 = Warp.run 8080 rou1
157
158 hspec =
159 testSpecs $
160 with (return rou1) $
161 it "allows running arbitrary monads" $ do
162 get "/date" `shouldRespondWith` 200