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 IO.Async.Loop.Epoll

  9 | import System

 11 | %default total

 13 | prettyNS : Integer -> String

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

 15 |   where

 16 |     secs, msecs, usecs, nsecs : String

 17 |     secs =

 18 |       case n `div` 1_000_000_000 of

 19 |         0 => ""

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

 22 |     msecs =

 23 |       case n `div` 1_000_000 of

 24 |         0 => ""

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

 27 |     usecs =

 28 |       case n `div` 1_000 of

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

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

 37 | largeBody : Nat -> RequestErr

 38 | largeBody n =

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

 40 |     requestErr contentTooLarge413

 42 | largeHeader : Nat -> RequestErr

 43 | largeHeader n =

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

 45 |     requestErr requestHeaderFieldsTooLarge431

 47 | badRequest : RequestErr

 48 | badRequest = requestErr badRequest400

 50 | 0 Bytes : List Type -> Type

 51 | Bytes es = HTTPStream es ByteString

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

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

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

 61 | CONTENT_LENGTH : String

 62 | CONTENT_LENGTH = "CONTENT_LENGTH"

 64 | REQUEST_URI : String

 65 | REQUEST_URI = "REQUEST_URI"

 67 | REQUEST_METHOD : String

 68 | REQUEST_METHOD = "REQUEST_METHOD"

 70 | CONTENT_TYPE : String

 71 | CONTENT_TYPE = "CONTENT_TYPE"

 73 | HTTP_PRE : ByteString

 74 | HTTP_PRE = "HTTP_"

 76 | adjhname : ByteString -> String

 77 | adjhname bs =

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

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

 81 | scgiHeader n v hs =

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

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

 84 |   else insertHeader n v hs

 86 | parameters {auto conf : Config}

 87 |            {auto has  : Has RequestErr es}

 88 |            {auto log  : HTTPLogger}

 90 |   contentLength : Headers -> HTTPPull o es Nat

 91 |   contentLength hs =

 92 |    let c := contentLength hs

 93 |     in case c > conf.maxMsgSize of

 94 |          False => pure c

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

 97 |   parseRequestURI : Headers -> HTTPPull o es URI

 98 |   parseRequestURI hs =

 99 |     maybe (throw badRequest) requestURI $

100 |       lookupUpperCaseHeader REQUEST_URI hs

102 |   parseRequestMethod : Headers -> HTTPPull o es Method

103 |   parseRequestMethod hs =

104 |     maybe (throw badRequest) requestMethod $

105 |       lookupUpperCaseHeader REQUEST_METHOD hs

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

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

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

110 |   -- separated by zero bytes.

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

112 |   headerSize p =

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

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

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

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

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

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

120 |   header n p =

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

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

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

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

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

127 |     where

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

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

130 |       go hs _         = hs

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

133 |   request p = Prelude.do

134 |     (hsz, rem1) <- headerSize p

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

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

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

138 |     cl          <- contentLength head

139 |     m           <- parseRequestMethod head

140 |     u           <- parseRequestURI head

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

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

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

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

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

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

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

149 |   where

150 |     msg, dts : List String

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

153 |     dts = case d of

154 |       "" => []

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

157 |     msgLines : List String

158 |     msgLines =

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

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

161 |       in m :: msg ++ dts

163 | parameters {auto log : HTTPLogger}

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)