{-# LANGUAGE PackageImports #-} {-| Module : Server Description : Run a server. License : BSD 3 Maintainer : terezasokol@gmail.com Stability : experimental Portability : POSIX -} module Server (Route, listen, get, post, text, json, file, body, getLogin, getToken, findHeader) where import qualified Control.Exception.Safe as Control import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Maybe as HMaybe import qualified Data.Either as Either import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Base64 as Base64 import qualified "text-utf8" Data.Text as T import qualified "text-utf8" Data.Text.Lazy as TL import qualified "text-utf8" Data.Text.Encoding as Encoding import qualified "text-utf8" Data.Text.Encoding.Error as Encoding import qualified Data.Time.Clock.POSIX as POSIX import qualified Data.CaseInsensitive as CI import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Middleware.Static as Static import qualified Network.Wai.Middleware.RequestLogger as RequestLogger import qualified Network.HTTP.Types as HTTP import qualified Network.HTTP.Types.Method as Method import qualified Network.HTTP.Types.Header as Header import qualified Prelude import qualified Maybe import qualified String import qualified Debug import qualified List import qualified Tuple import qualified Http import qualified Result import qualified Dict import qualified Task import qualified Terminal import qualified Url import qualified Url.Parser as Parser import qualified Interop import qualified Json.Encode as E import qualified Json.Decode as D import Cherry.Prelude import Url.Parser (Parser) {-| -} type Port = Int {-| -} listen :: Port -> String -> List Route -> Task String () listen port public routes = let log = RequestLogger.logStdoutDev static = Static.staticPolicy (Static.addBase (String.toList public)) listen_ = Warp.run port application_ |> Interop.enter |> Task.mapError (\_ -> "Could not start server.") application_ = application public routes |> log |> static in do Terminal.write (String.concat [ "Listening on port ", String.fromInt port, "..." ]) listen_ {-| -} newtype Route = Route (Http.Request -> Url.Url -> Maybe (Task String Http.Response)) {-| -} get :: Parser a (Task String Http.Response) -> (Http.Request -> a) -> Route get parser handler = Route <| \request url -> if Wai.requestMethod request == Method.methodGet then Parser.parse (Parser.map (handler request) parser) url else Nothing {-| -} post :: Parser a (Task String Http.Response) -> (Http.Request -> a) -> Route post parser handler = Route <| \request url -> if Wai.requestMethod request == Method.methodPost then Parser.parse (Parser.map (handler request) parser) url else Nothing {-| -} text :: Int -> String -> Http.Response text statusNo string = Wai.responseLBS (statusCode statusNo) [] (String.toLazyByteString string) {-| -} json :: Int -> E.Value -> Http.Response json statusNo value = Wai.responseBuilder (statusCode statusNo) [] (E.toBuilder value) {-| -} file :: Int -> String -> Http.Response file statusNo path = Wai.responseFile (statusCode statusNo) [] (String.toList path) HMaybe.Nothing -- HELPERS {-| -} body :: D.Decoder a -> Http.Request -> Task.Task String a body decoder request = let getChunks :: List B.ByteString -> Task.Task String B.ByteString getChunks chunks = Wai.getRequestBodyChunk request |> Interop.enter |> Task.mapError (\_ -> "Body could not be parsed") |> Task.andThen (\chunk -> if chunk == B.empty then Task.succeed (B.concat (List.reverse chunks)) else getChunks (chunk : chunks) ) decode bs = String.fromByteString bs |> D.fromString decoder |> fromResult fromResult result = case result of Ok v -> Task.succeed v Err e -> Task.fail "Body could not be parsed" in getChunks [] |> Task.andThen decode -- HELPERS / AUTH {-| -} getToken :: Http.Request -> Result String String getToken request = findHeader "Authorization" request |> Result.map dropBasic |> Result.andThen decodeBase64 {-| -} getLogin :: Http.Request -> Result String ( String, String ) getLogin request = findHeader "Authorization" request |> Result.map dropBasic |> Result.andThen decodeBase64 |> Result.andThen textToAuthForm dropBasic :: String -> String dropBasic = String.dropLeft 6 decodeBase64 :: String -> Result String String decodeBase64 value = value |> String.toByteString |> Base64.decode |> Result.fromEither |> Result.mapError String.fromList |> Result.map String.fromByteString textToAuthForm :: String -> Result String ( String, String ) textToAuthForm text = case String.split ":" text of [ email, password ] -> Ok ( email, password ) _ -> Err ("Bad value: " ++ text) -- HELPERS / HEADER {-| -} findHeader :: CI.CI B.ByteString -> Http.Request -> Result String String findHeader name request = let isCorrect ( header, value ) = header == name getValue ( header, value ) = value nameAsError = String.fromByteString (CI.original name) in findFirst isCorrect (Wai.requestHeaders request) |> Maybe.map getValue |> Result.fromMaybe ("Request is missing \"" ++ nameAsError ++ "\" header.") |> Result.map String.fromByteString findFirst :: (a -> Bool) -> List a -> Maybe a findFirst isCorrect all = case all of a : rest -> if isCorrect a then Just a else findFirst isCorrect rest [] -> Nothing -- INTERNAL application :: String -> List Route -> Wai.Application application public routes request respond = let url = requestToUrl request allRoutes = collectRoutes public routes in findResponse public url request allRoutes |> Task.attempt |> Interop.andThen (toSafeResponse >> respond) requestToUrl :: Http.Request -> Url.Url requestToUrl request = let toPath request = Wai.rawPathInfo request |> String.fromByteString toQuery request = Wai.rawQueryString request |> B.tail |> String.fromByteString |> nothingIfEmpty nothingIfEmpty string = if String.isEmpty string then Nothing else Just string in Url.Url { Url.path = toPath request , Url.query = toQuery request } findResponse :: String -> Url.Url -> Http.Request -> List Route -> Task String Http.Response findResponse public url request remaining = case remaining of Route next : rest -> case next request url of Just response -> response Nothing -> findResponse public url request rest [] -> Task.succeed (serve404 public) collectRoutes :: String -> List Route -> List Route collectRoutes public routes = routes ++ [ homeRoute public ] homeRoute :: String -> Route homeRoute public = get Parser.top <| \_ -> Task.succeed (serveIndex public) statusCode :: Int -> HTTP.Status statusCode statusNo = case statusNo of 200 -> HTTP.status200 404 -> HTTP.status404 401 -> HTTP.status401 501 -> HTTP.status501 _ -> HTTP.status404 -- TODO -- RESPONSES serveIndex :: String -> Http.Response serveIndex public = file 200 (String.concat [ public, "/index.html" ]) serve404 :: String -> Http.Response serve404 public = file 404 (String.concat [ public, "/404.html" ]) internalError :: String -> Http.Response internalError err = Wai.responseLBS HTTP.status500 [] (String.toLazyByteString err) notFound :: Http.Response notFound = Wai.responseLBS HTTP.status404 [] "Route not found" toSafeResponse :: Result String Http.Response -> Http.Response toSafeResponse result = case result of Result.Ok response -> response Result.Err msg -> internalError msg