
   0 | ||| HTTP server implementation
   1 | module Pact.Server.HTTP
   2 | 
   3 | import Pact.Server.Core
   4 | import Pact.Server.Util
   5 | 
   6 | import public Data.SortedMap
   7 | import Data.ByteVect as BV
   8 | import public FS.Posix
   9 | import public FS.Socket
  10 | 
  11 | import public IO.Async.Loop.Posix
  12 | import public IO.Async.Loop.Epoll
  13 | import public System
  14 | 
  15 | import Derive.Prelude
  16 | import Control.Monad.Reader
  17 | 
  18 | import Pact.WAI
  19 | import Pact.API
  20 | 
  21 | %default total
  22 | 
  23 | ||| Prog type is the core type for the server's asynchronous stream program
  24 | ||| Based on Poll event loop and AsyncStream for asynchronous IO
  25 | 0 Prog : List Type -> Type -> Type
  26 | Prog = AsyncStream Poll
  27 | 
  28 | ||| Run the HTTP server
  29 | ||| 
  30 | ||| Accepts an asynchronous program and executes it in the epoll event loop
  31 | ||| @ prog The server program to execute
  32 | covering
  33 | runServer' : Prog [Errno] Void -> IO ()
  34 | runServer' prog = epollApp $ mpull (handle [stderrLn . interpolate] prog)
  35 | 
  36 | ||| MaxHeaderSize is the maximum size of an HTTP header
  37 | ||| MaxContentSize is the maximum size of an HTTP content
  38 | %inline
  39 | MaxHeaderSize, MaxContentSize : Nat
  40 | MaxHeaderSize = 0xffff
  41 | MaxContentSize = 0xffff_ffff
  42 | 
  43 | ||| SPACE is the space character
  44 | ||| COLON is the colon character
  45 | %inline
  46 | SPACE, COLON : Bits8
  47 | SPACE = 32
  48 | COLON = 58
  49 | 
  50 | ||| Parse the start line of an HTTP request
  51 | ||| 
  52 | ||| Extracts HTTP method, target path, and HTTP version
  53 | ||| @ bs ByteString containing the start line
  54 | startLine : ByteString -> Either HTTPErr (Method,String,Version)
  55 | startLine bs =
  56 |   case toString <$> split SPACE (trim bs) of
  57 |     [m,t,v] => [| (\x,y,z => (x,y,z)) (method m) (pure t) (version v) |]
  58 |     _       => Left InvalidRequest
  59 | 
  60 | 
  61 | ||| Parse HTTP request headers
  62 | ||| 
  63 | ||| Recursively processes the header list and builds the header map
  64 | ||| @ hs Currently parsed header map
  65 | ||| @ t List of ByteStrings to parse
  66 | headers : Headers -> List ByteString -> Either HTTPErr Headers
  67 | headers hs []     = Right hs
  68 | headers hs (h::t) =
  69 |   case break (COLON ==) h of
  70 |     (xs,BS (S k) bv) =>
  71 |      let name := toLower (toString xs)
  72 |          val  := toString (trim $ tail bv)
  73 |       in headers (insert name val hs) t
  74 |     _                => Left InvalidRequest
  75 | 
  76 | 
  77 | ||| Get content length from HTTP headers
  78 | ||| @ hs HTTP header map
  79 | contentLength : Headers -> Nat
  80 | contentLength = maybe 0 cast . lookup "content-length"
  81 | 
  82 | ||| Get content type from HTTP headers
  83 | ||| @ hs HTTP header map
  84 | contentType : Headers -> Maybe String
  85 | contentType = lookup "content-type"
  86 | 
  87 | 
  88 | ||| Assemble HTTP request object
  89 | ||| 
  90 | ||| Assembles parsed HTTP components into a complete Request object
  91 | ||| @ p Asynchronous pull stream of HTTP ByteStrings
  92 | assemble :
  93 |      HTTPPull (List ByteString) (HTTPStream ByteString)
  94 |   -> HTTPPull o (Maybe Request)
  95 | assemble p = Prelude.do
  96 |   Right (h,rem) <- C.uncons p | _ => pure Nothing
  97 |   (met,uri,vrs) <- injectEither (startLine h)
  98 |   (hs,body)     <- foldPairE headers empty rem
  99 |   let cl := contentLength hs
 100 |       ct := contentType hs
 101 |       queryParams := SortedMap.fromList $ []
 102 |   when (cl > MaxContentSize) (throw ContentSizeExceeded)
 103 |   pure $ Just (MkRequest met uri queryParams vrs hs cl ct $ C.take cl body)
 104 | 
 105 | 
 106 | ||| Parse HTTP request from HTTP byte stream
 107 | ||| 
 108 | ||| @ req HTTP byte stream
 109 | request : RequestBody -> HTTPPull o (Maybe Request)
 110 | request req =
 111 |      breakAtSubstring pure "\r\n\r\n" req
 112 |   |> C.limit HeaderSizeExceeded MaxHeaderSize
 113 |   |> lines
 114 |   |> assemble
 115 | 
 116 | ||| encodeResponse' is a function that encodes an HTTP response
 117 | ||| 
 118 | ||| Generates an HTTP response ByteString with status code and body
 119 | ||| @ status HTTP status code
 120 | ||| @ body Response body content
 121 | export
 122 | encodeResponse' : Response -> ByteString
 123 | encodeResponse' res =  let bs = fromString . renderResponse $ res in bs
 124 | 
 125 | 
 126 | ||| Generate 400 Bad Request response
 127 | ||| @ return ByteString
 128 | export
 129 | badRequestHTTP : String -> ByteString
 130 | badRequestHTTP body = fromString $ renderResponse (badRequestResponse body)
 131 | 
 132 | ||| serve is a function that handles a single client connection
 133 | ||| 
 134 | ||| Reads client request and returns response, then closes the connection
 135 | ||| @ app Application handler function
 136 | ||| @ cli Client socket
 137 | covering
 138 | consumeSocket: HTTPApplication -> Socket AF_INET -> Async Poll [] ()
 139 | consumeSocket app cli =
 140 |   flip guarantee (close' cli) $
 141 |     mpull $ handleErrors (\(Here x) => stderrLn "\{x}") $
 142 |          bytes cli 0xfff
 143 |       |> request
 144 |       |> handleRequest'
 145 |   where
 146 |     response : Maybe Request -> HTTPStream ByteString
 147 |     response Nothing  = pure ()
 148 |     response (Just r) = let s1 =  app r in mapOutput encodeResponse' s1
 149 | 
 150 |     handleRequest' : HTTPPull ByteString (Maybe Request) -> AsyncStream Poll [Errno] Void
 151 |     handleRequest' p =
 152 |       extractErr HTTPErr (writeTo cli (p >>= response)) >>= \case
 153 |         Left err => emit (badRequestHTTP (show err)) |> writeTo cli
 154 |         Right () => pure ()
 155 | 
 156 |     -- handleRequest'' : HTTPPull ByteString (Maybe Request) -> HTTPPull ByteString (Maybe Response)
 157 |     handleRequest'' p = onError (writeTo cli (p >>= response)) $ \errs => case errs of
 158 |       _ => pure ()
 159 |     
 160 | ||| serverFunc is a function that creates and starts an HTTP server
 161 | ||| 
 162 | ||| Creates HTTP server according to the provided config and application
 163 | ||| @ config Server configuration
 164 | ||| @ app Application handler function
 165 | ||| @ return Prog [Errno] Void
 166 | covering
 167 | serverFunc : ServerConfig -> HTTPApplication -> Prog [Errno] Void
 168 | serverFunc config app =
 169 |   let conn = acceptOn AF_INET SOCK_STREAM config.bind
 170 |       serve' = consumeSocket app
 171 |   in
 172 |   case config.maxConns of
 173 |     S k => foreachPar (S k) serve' conn
 174 |     Z   => foreachPar 1 serve' conn
 175 | 
 176 | covering
 177 | public export
 178 | run: ServerConfig -> HTTPApplication -> IO ()
 179 | run config app = runServer' $ serverFunc config app