Skip to content

Commit 1c486d1

Browse files
ProggerXProggerX
committed
Add web server POST route and update example
1 parent 28f10bc commit 1c486d1

7 files changed

Lines changed: 134 additions & 51 deletions

File tree

‎example/web-server.lp‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -10,7 +10,13 @@
1010
(last_name ln)
1111
(greeting $ greet fn ln)))
1212

13+
(defn fpost (txt fn ln) (concat txt " " fn " " ln))
14+
15+
(defn echo (body) body)
16+
1317
- Build + serve
1418
(serve
1519
$ routeGET "/greet" (list "fname" "lname") f
20+
$ routePOST "/post" (list "fname" "lname") fpost
21+
$ routePOST "/echo" () echo
1622
$ server 2025)

‎lapse.cabal‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
cabal-version: 3.0
22
name: lapse
3-
version: 1.4.0
3+
version: 1.4.1
44
license: GPL-3.0-only
55
license-file: LICENSE
66
author: ProggerX
@@ -24,6 +24,8 @@ library
2424
, Lapse.Web
2525
, Lapse.Web.Client
2626
, Lapse.Web.Server
27+
, Lapse.Web.Server.Get
28+
, Lapse.Web.Server.Post
2729
, Lapse.Web.Types
2830
, Lapse.Json
2931
hs-source-dirs:

‎src/Lapse/Web.hs‎

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,9 @@ module Lapse.Web where
33
import Data.Map.Strict (fromList)
44
import Lapse.Types (Scope, Value (..))
55
import Lapse.Web.Client
6-
import Lapse.Web.Server
6+
import Lapse.Web.Server (lserve, lserver)
7+
import Lapse.Web.Server.Get (lroutG)
8+
import Lapse.Web.Server.Post (lroutP)
79

810
mod :: Scope IO
911
mod =
@@ -19,5 +21,6 @@ mod =
1921
, -- --------------------------------
2022
("serve", Function lserve)
2123
, ("routeGET", Function lroutG)
24+
, ("routePOST", Function lroutP)
2225
, ("server", Function lserver)
2326
]

‎src/Lapse/Web/Server.hs‎

Lines changed: 21 additions & 48 deletions
Original file line numberDiff line numberDiff line change
@@ -3,22 +3,16 @@
33
module Lapse.Web.Server where
44

55
import Control.Monad.IO.Class (liftIO)
6-
import Control.Monad.State (evalStateT, get, lift)
76
import Data.ByteString.Char8 qualified as BC
87
import Data.ByteString.Lazy.Char8 qualified as BCL
9-
import Data.Map.Strict (elems, empty, fromList, insert, keys, (!?))
8+
import Data.Map.Strict (elems, empty, fromList, keys, (!?))
109
import Data.Typeable (cast)
11-
import Lapse.Lambda (UnList (..), unList)
1210
import Lapse.Types (Func, TBox (..), Value (..), ext)
13-
import Lapse.Web.Types (URL, WServer (..))
11+
import Lapse.Web.Types (URL, WBody, WServer (..))
1412
import Network.HTTP.Types (status200, status400, status404, urlDecode)
1513
import Network.Wai qualified as W
1614
import Network.Wai.Handler.Warp qualified as WRP
1715

18-
unString :: Value m -> String
19-
unString (String s) = s
20-
unString _ = error "Error: expected string but got not string"
21-
2216
parseUrlPath :: String -> URL
2317
parseUrlPath url =
2418
let (path, query) = break (== '?') url
@@ -40,41 +34,8 @@ splitOn delimiter str =
4034
[] -> []
4135
(_ : xs) -> splitOn delimiter xs
4236

43-
unString' :: Value m -> String
44-
unString' (String s) = s
45-
unString' v = show v
46-
47-
lroutG :: Func IO
48-
lroutG (Pair (String url) (Pair args' (Pair (Function f) (Pair (External (TBox srv)) Nil)))) = do
49-
st <- get
50-
cnt <- lift get
51-
case cast @_ @WServer srv of
52-
Just s@WServer{routesGET} ->
53-
let tm x =
54-
pure $
55-
ext
56-
s
57-
{ routesGET =
58-
insert
59-
url
60-
( x
61-
, (`evalStateT` cnt)
62-
. (`evalStateT` st)
63-
. fmap (BCL.pack . unString')
64-
. f
65-
. foldr (Pair . String) Nil
66-
)
67-
routesGET
68-
}
69-
in case unList args' of
70-
Single (String arg) -> tm [arg]
71-
Proper args -> tm $ map unString args
72-
_ -> lroutG Nil
73-
Nothing -> lroutG Nil
74-
lroutG _ = error "routeGET error, valid syntax: routeGET <url> <args> <func>"
75-
76-
respond :: WServer -> URL -> IO W.Response
77-
respond WServer{routesGET} (url, params) =
37+
respond :: WServer -> URL -> WBody -> IO W.Response
38+
respond WServer{routesGET, routesPOST} (url, params) =
7839
case routesGET !? url of
7940
Just (crNames, f) -> do
8041
let names = keys params
@@ -83,11 +44,23 @@ respond WServer{routesGET} (url, params) =
8344
let validNames = foldr ((&&) . uncurry (==)) True names'
8445
let validLengths = (length names == length crNames) && (length values == length names)
8546
if validNames && validLengths
86-
then do
47+
then const do
8748
res <- f values
8849
pure $ W.responseLBS status200 [] res
89-
else pure $ W.responseLBS status400 [] $ BCL.pack "Bad Request"
90-
Nothing -> pure $ W.responseLBS status404 [] $ BCL.pack $ "No such endpoint: " ++ url
50+
else const $ pure $ W.responseLBS status400 [] $ BCL.pack "Bad Request"
51+
Nothing -> case routesPOST !? url of
52+
Just (crNames, f) -> do
53+
let names = keys params
54+
let values = elems params
55+
let names' = zip names crNames
56+
let validNames = foldr ((&&) . uncurry (==)) True names'
57+
let validLengths = (length names == length crNames) && (length values == length names)
58+
if validNames && validLengths
59+
then \body -> do
60+
res <- f body values
61+
pure $ W.responseLBS status200 [] res
62+
else const $ pure $ W.responseLBS status400 [] $ BCL.pack "Bad Request"
63+
Nothing -> const $ pure $ W.responseLBS status404 [] $ BCL.pack $ "No such endpoint: " ++ url
9164

9265
lserve :: Func IO
9366
lserve (Pair (External (TBox srv)) Nil) =
@@ -96,12 +69,12 @@ lserve (Pair (External (TBox srv)) Nil) =
9669
liftIO
9770
( WRP.run port \req res ->
9871
let path r = BC.unpack $ urlDecode False $ W.rawPathInfo r <> W.rawQueryString r
99-
in respond s (parseUrlPath $ path req) >>= res
72+
in W.strictRequestBody req >>= \body -> respond s (parseUrlPath $ path req) (BCL.unpack body) >>= res
10073
)
10174
>> pure Nil
10275
Nothing -> lserve Nil
10376
lserve _ = error "serve expected exactly one argument :: WServer"
10477

10578
lserver :: Func IO
106-
lserver (Pair (Number port) Nil) = pure $ ext WServer{port, routesGET = empty}
79+
lserver (Pair (Number port) Nil) = pure $ ext WServer{port, routesGET = empty, routesPOST = empty}
10780
lserver _ = error "Expected integer port as argument to server"

‎src/Lapse/Web/Server/Get.hs‎

Lines changed: 46 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,46 @@
1+
module Lapse.Web.Server.Get where
2+
3+
import Control.Monad.State (evalStateT, get, lift)
4+
import Data.ByteString.Lazy.Char8 qualified as BCL
5+
import Data.Map.Strict (insert)
6+
import Data.Typeable (cast)
7+
import Lapse.Lambda (UnList (..), unList)
8+
import Lapse.Types (Func, TBox (..), Value (..), ext)
9+
import Lapse.Web.Types (WServer (..))
10+
11+
unString :: Value m -> String
12+
unString (String s) = s
13+
unString _ = error "Error: expected string but got not string"
14+
15+
unString' :: Value m -> String
16+
unString' (String s) = s
17+
unString' v = show v
18+
19+
lroutG :: Func IO
20+
lroutG (Pair (String url) (Pair args' (Pair (Function f) (Pair (External (TBox srv)) Nil)))) = do
21+
st <- get
22+
cnt <- lift get
23+
case cast @_ @WServer srv of
24+
Just s@WServer{routesGET} ->
25+
let tm x =
26+
pure $
27+
ext
28+
s
29+
{ routesGET =
30+
insert
31+
url
32+
( x
33+
, (`evalStateT` cnt)
34+
. (`evalStateT` st)
35+
. fmap (BCL.pack . unString')
36+
. f
37+
. foldr (Pair . String) Nil
38+
)
39+
routesGET
40+
}
41+
in case unList args' of
42+
Single (String arg) -> tm [arg]
43+
Proper args -> tm $ map unString args
44+
_ -> lroutG Nil
45+
Nothing -> lroutG Nil
46+
lroutG _ = error "routeGET error, valid syntax: routeGET <url> <args> <func>"

‎src/Lapse/Web/Server/Post.hs‎

Lines changed: 47 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,47 @@
1+
module Lapse.Web.Server.Post where
2+
3+
import Control.Monad.State (evalStateT, get, lift)
4+
import Data.ByteString.Lazy.Char8 qualified as BCL
5+
import Data.Map.Strict (insert)
6+
import Data.Typeable (cast)
7+
import Lapse.Lambda (UnList (..), unList)
8+
import Lapse.Types (Func, TBox (..), Value (..), ext)
9+
import Lapse.Web.Types (WServer (..))
10+
11+
unString :: Value m -> String
12+
unString (String s) = s
13+
unString _ = error "Error: expected string but got not string"
14+
15+
unString' :: Value m -> String
16+
unString' (String s) = s
17+
unString' v = show v
18+
19+
lroutP :: Func IO
20+
lroutP (Pair (String url) (Pair args' (Pair (Function f) (Pair (External (TBox srv)) Nil)))) = do
21+
st <- get
22+
cnt <- lift get
23+
case cast @_ @WServer srv of
24+
Just s@WServer{routesPOST} ->
25+
let tm x =
26+
pure $
27+
ext
28+
s
29+
{ routesPOST =
30+
insert
31+
url
32+
( x
33+
, \body params ->
34+
(`evalStateT` cnt)
35+
. (`evalStateT` st)
36+
. fmap (BCL.pack . unString')
37+
. f
38+
$ foldr (Pair . String) Nil (body : params)
39+
)
40+
routesPOST
41+
}
42+
in case unList args' of
43+
Single (String arg) -> tm [arg]
44+
Proper args -> tm $ map unString args
45+
_ -> lroutP Nil
46+
Nothing -> lroutP Nil
47+
lroutP _ = error "routeGET error, valid syntax: routeGET <url> <args> <func>"

‎src/Lapse/Web/Types.hs‎

Lines changed: 7 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -20,7 +20,13 @@ instance Show WResponse where
2020

2121
type URL = (String, Map String String)
2222

23-
data WServer = WServer {port :: Int, routesGET :: Map String ([String], [String] -> IO BS.ByteString)}
23+
type WBody = String
24+
25+
data WServer = WServer
26+
{ port :: Int
27+
, routesGET :: Map String ([String], [String] -> IO BS.ByteString)
28+
, routesPOST :: Map String ([String], WBody -> [String] -> IO BS.ByteString)
29+
}
2430

2531
instance Eq WServer where
2632
_ == _ = error "Can't compare servers"

0 commit comments

Comments
 (0)