0 | module Network.SCGI

  2 | import public HTTP.API.Server

  3 | import public Network.SCGI.Config

  5 | import Data.SortedMap as SM

  6 | import Data.String

  7 | import FS.Socket

  8 | import System

 10 | %default total

 12 | prettyNS : Integer -> String

 13 | prettyNS n = "\{secs}\{msecs}\{usecs}\{nsecs}"

 14 |   where

 15 |     secs, msecs, usecs, nsecs : String

 16 |     secs =

 17 |       case n `div` 1_000_000_000 of

 18 |         0 => ""

 19 |         s => "\{show s} s "

 21 |     msecs =

 22 |       case n `div` 1_000_000 of

 23 |         0 => ""

 24 |         s => "\{show $ s `mod` 1000} ms "

 26 |     usecs =

 27 |       case n `div` 1_000 of

 28 |         s => "\{show $ s `mod` 1000} us "

 30 |     nsecs = "\{show $ n `mod` 1000} ns"

 36 | largeBody : Nat -> RequestErr

 37 | largeBody n =

 38 |   {message := "Maximum content size is \{show n} bytes"} $

 39 |     requestErr contentTooLarge413

 41 | largeHeader : Nat -> RequestErr

 42 | largeHeader n =

 43 |   {message := "Maximum header size is \{show n} bytes"} $

 44 |     requestErr requestHeaderFieldsTooLarge431

 46 | badRequest : RequestErr

 47 | badRequest = requestErr badRequest400

 49 | 0 Bytes : List Type -> Type

 50 | Bytes es = HTTPStream es ByteString

 52 | queryLine : (ByteString,QueryVal) -> String

 53 | queryLine (n,QVal v) = "\{n}: \{v}"

 54 | queryLine (n,QEmpty) = "\{n}"

 60 | CONTENT_LENGTH : String

 61 | CONTENT_LENGTH = "CONTENT_LENGTH"

 63 | REQUEST_URI : String

 64 | REQUEST_URI = "REQUEST_URI"

 66 | REQUEST_METHOD : String

 67 | REQUEST_METHOD = "REQUEST_METHOD"

 69 | CONTENT_TYPE : String

 70 | CONTENT_TYPE = "CONTENT_TYPE"

 72 | HTTP_PRE : ByteString

 73 | HTTP_PRE = "HTTP_"

 75 | adjhname : ByteString -> String

 76 | adjhname bs =

 77 |   ByteString.toString $ if HTTP_PRE `isPrefixOf` bs then drop (size HTTP_PRE) bs else bs

 79 | scgiHeader : String -> ByteString -> Headers -> Headers

 80 | scgiHeader n v hs =

 81 |   if      n == CONTENT_LENGTH then insertHeader Content_Length v hs

 82 |   else if n == CONTENT_TYPE then insertHeader Content_Type v hs

 83 |   else insertHeader n v hs

 85 | parameters {auto conf : Config}

 86 |            {auto has  : Has RequestErr es}

 87 |            {auto log  : HTTPLogger}

 89 |   contentLength : Headers -> HTTPPull o es Nat

 90 |   contentLength hs =

 91 |    let c := contentLength hs

 92 |     in case c > conf.maxMsgSize of

 93 |          False => pure c

 94 |          True  => throw (largeBody conf.maxMsgSize)

 96 |   parseRequestURI : Headers -> HTTPPull o es URI

 97 |   parseRequestURI hs =

 98 |     maybe (throw badRequest) requestURI $

 99 |       lookupUpperCaseHeader REQUEST_URI hs

101 |   parseRequestMethod : Headers -> HTTPPull o es Method

102 |   parseRequestMethod hs =

103 |     maybe (throw badRequest) requestMethod $

104 |       lookupUpperCaseHeader REQUEST_METHOD hs

106 |   -- An SCGI request starts with the header size (in decimal)

107 |   -- followed by a colon (ASCII: 58): "75:" followed by a header of

108 |   -- name-value pairs of the given number of bytes (here: 75)

109 |   -- separated by zero bytes.

110 |   headerSize : Bytes es -> HTTPPull o es (Nat, Bytes es)

111 |   headerSize p =

112 |        C.forceBreakFull badRequest DropHit (58 ==) p

113 |     |> C.limit (largeHeader conf.maxHeaderSize) 10

114 |     |> P.foldPair (<+>) empty

115 |     |> map (mapFst $ fromMaybe 0 . ByteString.parseDecimalNat)

117 |   -- The header consists of name-value pairs separated by zero bytes.

118 |   header : Nat -> Bytes es -> HTTPPull o es (Headers, Bytes es)

119 |   header n p =

120 |        C.splitAt n p                  -- keep the given number of bytes

121 |     |> C.split (0 ==)                 -- split them at 0

122 |     |> P.observe (\xs => traceML $ map (\x => "Header part: \{x}") xs)

123 |     |> P.foldPair (++) []             -- accumulated everything in a single list

124 |     |> map (mapFst $ go emptyHeaders) -- put name-value pairs in a sorted map

126 |     where

127 |       go : Headers -> List ByteString -> Headers

128 |       go hs (x::y::t) = go (scgiHeader (adjhname x) y hs) t

129 |       go hs _         = hs

131 |   request : Bytes es -> HTTPPull o es Request

132 |   request p = Prelude.do

133 |     (hsz, rem1) <- headerSize p

134 |     when (hsz > conf.maxHeaderSize) (throw $ largeHeader conf.maxHeaderSize)

135 |     (head,rem2) <- header hsz rem1

136 |     exec $ debugML ((\(k,v) => "\{k}: \{v}") <$> kvList head)

137 |     cl          <- contentLength head

138 |     m           <- parseRequestMethod head

139 |     u           <- parseRequestURI head

140 |     exec $ info "Got a \{show m} request at \{encodePath u} (\{show cl} bytes)"

141 |     exec $ debugML ("queries:" :: map queryLine u.queries)

142 |     body        <- foldGet (:<) [<] (C.take cl $ C.drop 1 rem2)

143 |     pure $ RQ m head u (fastConcat $ body <>> [])

145 | logErr : HTTPLogger => RequestErr -> HTTPPull o es ()

146 | logErr (RE s e m d p) =

147 |   exec $ if "" == p then warnML msgLines else infoML msgLines

148 |   where

149 |     msg, dts : List String

150 |     msg = if "" == m then [] else ["message: \{m}"]

152 |     dts = case d of

153 |       "" => []

154 |       _  => "details:" :: map (indent 2) (String.lines d)

156 |     msgLines : List String

157 |     msgLines =

158 |      let u := if "" == p then "" else "at \{p}"

159 |          m := "invalid request \{u} (status code \{show s}): \{e}"

160 |       in m :: msg ++ dts

162 | parameters {auto log : HTTPLogger}

163 |            {auto loc : HTTPLocal}

165 |   ||| An empty stream used for receiving requests and sending

173 |   export

174 |   serveStream : Config -> (Request -> Handler Response) -> HTTPStream [] Void

175 |   serveStream c@(C a p _ _ co) run =

176 |     handle handlers $ 

177 |       parBind co doServe (acceptOn AF_INET SOCK_STREAM $ IP4 a p)

179 |     where

180 |       handlers : All (\e => e -> HTTPPull Void [] ())  [Errno]

181 |       handlers = [exec . ierror]

183 |       %inline

184 |       request' : Socket AF_INET -> HTTPPull o [RequestErr,Errno] Request 

185 |       request' cli = request $ bytes cli 0xffff

187 |       send : Socket AF_INET -> Response -> HTTPStream [Errno] Void

188 |       send cli resp = writeTo cli (emits $ responseBytes resp)

190 |       doServe : Socket AF_INET -> HTTPStream [Errno] Void

191 |       doServe cli = weakenErrors $ Prelude.do

192 |         c1 <- liftIO $ clockTime Monotonic

193 |         d  <- finally (close' cli) $ handle handlers $

194 |                 extractErr RequestErr (request' cli) >>= \case

195 |                   Left x  => logErr x >> send cli (fromError Nothing emptyHeaders x)

196 |                   Right req => exec (weakenErrors $ extractErr RequestErr $ run req) >>= \case

197 |                     Left x  => logErr x >> send cli (fromError (Just req.uri) req.headers x)

198 |                     Right resp => send cli resp

199 |         c2 <- liftIO $ clockTime Monotonic

200 |         exec $ debug "request served in \{prettyNS $ toNano $ timeDifference c2 c1}"

202 |   ||| This is the end of the world where we serve the

208 |   export covering

209 |   serve : Config -> (Request -> Handler Response) -> HTTPProg [] ()

210 |   serve c run = mpull (serveStream c run)

212 |   ||| Simplified version of `serve` used for wrapping a simple `IO`

217 |   export covering

218 |   serveIO : Config -> (Request -> IO Response) -> IO ()

219 |   serveIO c run = simpleApp (serve c $ liftIO . run)