0 | ||| Experimental API definition
  1 | module Pact.Server.Util
  2 |
  3 | import Data.String
  4 | import Data.Vect
  5 | import Data.Vect.Quantifiers
  6 | import Data.List1
  7 | import JSON
  8 |
  9 | import Pact.WAI
 10 | import Pact.API
 11 |
 12 | import Pact.Server.Core
 13 | import FS.Core
 14 |
 15 | import FS.Posix
 16 | import FS.Socket
 17 |
 18 | import IO.Async.Loop.Posix
 19 | import IO.Async.Loop.Epoll
 20 | import FS.Concurrent
 21 |
 22 | import Control.Monad.Error.Either
 23 |
 24 |
 25 | %default total
 26 | %default covering
 27 |
 28 |
 29 | ||| Match an API against a list of path segments.
 30 | |||
 31 | ||| @api The API to match.
 32 | ||| @segs The list of path segments.
 33 | |||
 34 | ||| Returns a list of the parsed path parameters.
 35 | public export
 36 | matchAPI : (api: API) -> Vect m String -> Request -> Either String (HVect api.types)
 37 | matchAPI ((:>) { prf } path ep) segs req = if req.method == ep.method 
 38 |                           then matchPath path segs { allprf = prf }
 39 |                           else Left "Method not allowed"
 40 |
 41 | matchRouteItem : {m : Type -> Type} -> RouteItem m -> Vect n String -> Request -> Bool
 42 | matchRouteItem (api :=> handler) ss req = case matchAPI api ss req of
 43 |   Right vals => True
 44 |   Left err => False
 45 |
 46 |
 47 | findRouteItem : {m : Type -> Type} -> List (RouteItem m) -> Vect n String -> Request -> Maybe (RouteItem m)
 48 | findRouteItem [] _ req = Nothing
 49 | findRouteItem (item :: routes) segs req = case matchRouteItem item segs req of
 50 |     True => Just item
 51 |     False => findRouteItem routes segs req
 52 |
 53 | strToVect : String -> (n ** Vect n String)
 54 | strToVect s = (length list ** fromList list)
 55 |   where
 56 |   list : List String
 57 |   list = filter (/= "") . forget . split (== '/') $ s 
 58 |
 59 | findOnRouter  : {m : Type -> Type} -> Router m -> Request -> Maybe (RouteItem m)
 60 | findOnRouter (MkRouter routes) req = case strToVect req.uri of
 61 |   (n ** segs) => findRouteItem routes segs req
 62 |
 63 | applyHandler : (api : API) -> (params: HVect api.types) -> Lazy (Either DecodingErr (ApiReqBody api)) -> (handler: GetHandlerType m api) -> Either String (GetEPFromAPI m api)
 64 | applyHandler ((StaticPath _) :> ep) [()] _ handler = Right handler
 65 | applyHandler ((Capture _ t) :> ep) [param] _ handler = Right $ handler param
 66 | applyHandler ((ReqBody reqType) :> ep) _ (Right reqBody) handler = Right $ handler reqBody
 67 | applyHandler ((ReqBody reqType) :> ep) _ (Left err) handler = Left $ "parse error: \{show err}"
 68 | applyHandler ((:>) ((StaticPath _) :/ path')  ep { prf = prf' :: prfs}) (param :: params) reqBody handler = applyHandler {m} (path' :> ep) params reqBody handler
 69 | applyHandler ((:>) ((Capture _ t) :/ path')  ep { prf = prf' :: prfs}) (param :: params) reqBody handler = applyHandler {m} (path' :> ep) params reqBody $ handler param
 70 | -- applyHandler (((ReqBody reqType) :/ path') :> ep) (_ :: params) reqBody@(Just reqBody')  { allprf = prf :: prfs} handler = applyHandler {m} (path' :> ep) params reqBody $ handler reqBody'
 71 | applyHandler _ _ _ _ = Left "Invalid request"
 72 |
 73 | applyHandlerWithRequest : {m : Type -> Type} -> (routeItem : RouteItem m) -> (req : Request) -> String -> Either String (GetEndpointTypeFromRouteItem m routeItem)
 74 | applyHandlerWithRequest ((:=>) api@(path :> ep) handler { mimeRenderProof } { reqBodyProof }) req reqBody = 
 75 |   let uri = req.uri
 76 |       (_ ** segs) = strToVect uri
 77 |       eParams = matchPath path segs
 78 |       reqBody' : Either DecodingErr (PathReqBody path) = delay $ decode reqBody
 79 |   in case (eParams) of
 80 |     (Right params) => applyHandler {m} (path :> ep) params reqBody'  handler
 81 |     (Left err) => Left $ "\{err}"
 82 |
 83 |
 84 | emitResponse : (v: Verb) -> MimeRender (VerbAccept v) (VerbResponse v)  =>  VerbResponse v -> HTTPResponse
 85 | emitResponse (MkVerb _ code accept' response') res = emit $ MkResponse code headers (Just bodyStr)
 86 |   where
 87 |   bodyStr : String
 88 |   bodyStr = mimeRender { ctype = accept' } res
 89 |   bodyLen : String
 90 |   bodyLen =  show $ length bodyStr
 91 |   contentTypeStr : String
 92 |   contentTypeStr = show $ contentType { ctype = accept' }
 93 |   headers : Headers
 94 |   headers = if code == code_204 then emptyHeaders else fromList [("Content-Type", contentTypeStr ), ("Content-Length", bodyLen)]
 95 |
 96 |
 97 | accumAsString : Pull f ByteString es () -> Pull f q es String 
 98 | accumAsString p =
 99 |      foldGet (:<) [<] p
100 |   |> map (toString . ByteString.fastConcat . (<>> []))
101 |
102 | public export
103 | serve : {m : Type -> Type} -> Hoistable m => Router m -> Request -> HTTPResponse
104 | serve router req = accumAsString req.body >>= hand
105 |   where
106 |   hand : String -> HTTPResponse
107 |   hand reqBody = case findOnRouter router req of
108 |     Just routeItem@((:=>) api@(path :> verb) handler { mimeRenderProof } ) => case (applyHandlerWithRequest routeItem req reqBody) of
109 |       Right ioRes => (liftIO . runEitherT . hoist {m} $ ioRes ) >>= \case 
110 |         Right res => emitResponse verb res
111 |         Left err => throw err
112 |       Left err => throw InvalidRequest
113 |     Nothing => throw InvalidRequest