HttpServer.gren

effect module HttpServer where { subscription = HttpSub } exposing
    -- Init
    ( Permission
    , initialize

    -- Server
    , Server
    , ServerError(..)
    , createServer

    -- Requests
    , Request
    , Method(..)
    , methodToString
    , bodyAsString
    , bodyFromJson
    , requestInfo
    , onRequest
    )

{-| Create a server that can respond to HTTP requests.

You write your server using The Elm Architecture by subscribing to request
events and responding with commands in update.

See the [example project](https://github.com/gren-lang/example-projects/blob/main/http-server/src/Main.gren) for what this looks like.
Or the [integration tests](https://github.com/gren-lang/integration-tests/blob/main/http-server/src/Main.gren) for a more robust example with routing and multiple response types.

## Initialization

@docs Permission, Server, ServerError, initialize, createServer

## Requests

@docs Request, Method, methodToString, bodyAsString, bodyFromJson, requestInfo

## Responding to requests

@docs onRequest

See [HttpServer.Response](HttpServer.Response) for more details on responding to requests.

-}

import Bytes exposing (Bytes)
import Bytes.Decode as Decode
import Dict exposing (Dict)
import Init
import Internal.Init
import Json.Encode
import Json.Decode
import Node
import Task exposing (Task)
import Gren.Kernel.HttpServer
import HttpServer.Response exposing (Response(..))
import Url exposing (Url, Protocol(..))


-- INITIALIZATION


{-| The permission to start a [`Server`](HttpServer.Server).

You get this from [`initialize`](HttpServer.initialize).
-}
type Permission
    = Permission

{-| The HTTP server.
-}
type Server
    -- Note: Actual implementation in Kernel code
    = Server


{-| Error code and message from node.
Most likely from a failed attempt to start the server (e.g. `EADDRINUSE`).
Refer to the [node docs](https://nodejs.org/docs/latest-v18.x/api/errors.html) for details.
-}
type ServerError =
    ServerError { code : String, message : String }


{-| Initialize the [`HttpServer`](HttpServer) module and get permission to create a server.
-}
initialize : Init.Task Permission
initialize =
    Task.succeed Permission
        |> Internal.Init.Task



{-| Task to initialize a [`Server`](HttpServer#Server).
-}
createServer : Permission -> { host : String, port_ : Int } -> Task ServerError Server
createServer _ options =
    Gren.Kernel.HttpServer.createServer options.host options.port_


-- REQUESTS


{-| An incoming HTTP reqest.
-}
type alias Request =
    { headers : Dict String String
    , method : Method
    , body : Bytes
    , url : Url
   }


{-| HTTP request methods.
-}
type Method
    = GET
    | HEAD
    | POST
    | PUT
    | DELETE
    | CONNECT
    | TRACE
    | PATCH
    | UNKNOWN String


{-| String representation of method
-}
methodToString : Method -> String
methodToString method =
    when method is
        GET ->
            "GET"
        
        HEAD ->
            "HEAD"
        
        POST ->
            "POST"
        
        PUT ->
            "PUT"
        
        DELETE ->
            "DELETE"
        
        CONNECT ->
            "CONNECT"
        
        TRACE ->
            "TRACE"
        
        PATCH ->
            "PATCH"
        
        UNKNOWN value ->
            value


{-| Turn the pieces of a request into a [`Request`](HttpServer.Request) record.

This is only used internally.
-}
toRequest :
    { url : String
    , headers : Array String
    , method : String
    , body : Bytes
    }
    -> Request
toRequest 
    { url
    , headers
    , method
    , body 
    } =
    { method = toMethod method
    , body = body
    , url = 
        Url.fromString url
            |> Maybe.withDefault
                { protocol = Http
                , port_ = Nothing
                , host = ""
                , path = ""
                , query = Nothing
                , fragment = Nothing
                }
    , headers =
        headers
            |> arrayPairs
            |> dictFromPairs
    }


{-| Get request body as a string.
-}
bodyAsString : Request -> Maybe String
bodyAsString req =
    Bytes.toString req.body


{-| Get request body as json.
-}
bodyFromJson : Json.Decode.Decoder a -> Request -> Result Json.Decode.Error a
bodyFromJson decoder req =
    req
        |> bodyAsString
        |> Maybe.withDefault "" -- or better if result holds a maybe?
        |> Json.Decode.decodeString decoder


{-| Get a string representation of the request.

Good for logging.
-}
requestInfo : Request -> String
requestInfo req =
    let
        method
            = when req.method is
                GET ->
                    "GET"

                HEAD ->
                    "HEAD"

                POST ->
                    "POST"

                PUT ->
                    "PUT"

                DELETE ->
                    "DELETE"

                CONNECT ->
                    "CONNECT"

                TRACE ->
                    "TRACE"

                PATCH ->
                    "PATCH"

                UNKNOWN m ->
                    "UNKNOWN(" ++ m ++ ")"
    in
    method ++ " " ++ (Url.toString req.url)


toMethod : String -> Method
toMethod s =
    when s is
        "GET" ->
            GET
        
        "HEAD" ->
            HEAD

        "POST" ->
            POST
        
        "PUT" ->
            PUT
        
        "DELETE" ->
            DELETE
        
        "CONNECT" ->
            CONNECT
        
        "TRACE" ->
            TRACE
        
        "PATCH" ->
            PATCH
        
        _ ->
            UNKNOWN s


arrayPairs : Array String -> Array (Array String)
arrayPairs a =
    let
        pair = 
            Array.takeFirst 2 a
        
        rest =
            Array.dropFirst 2 a
        
        allPairs =
            [ pair ] ++ when rest is
                [] ->
                    []
                
                _ ->
                    arrayPairs rest
    in
    allPairs


dictFromPairs : Array (Array String) -> Dict String String
dictFromPairs pairs =
    let
        mapper p dict =
            when p is
                [a, b] ->
                    Dict.set a b dict
                
                _ ->
                    dict
    in
    Array.foldl mapper Dict.empty pairs


-- EFFECT STUFF


type HttpSub msg
    = OnRequestSub { server : Server, requestHandler : (Request -> Response -> msg) }


subMap : (a -> b) -> HttpSub a -> HttpSub b
subMap f sub =
    when sub is
        OnRequestSub { server, requestHandler } ->
            OnRequestSub { server = server, requestHandler = (\req res -> f (requestHandler req res)) }


type alias State msg =
    Array (HttpSub msg)


init : Task Never (State msg)
init =
    Task.succeed []


onEffects
    : Platform.Router msg SelfMsg
    -> Array (HttpSub msg)
    -> State msg
    -> Task Never (State msg)
onEffects router subs state =
    let
        _removeListeners =
            state
                |> Array.map
                    (\(OnRequestSub { server }) ->
                        Gren.Kernel.HttpServer.removeAllListeners server
                    )
        
        _addListeners =
            subs
                |> Array.map
                    (\(OnRequestSub { server, requestHandler }) ->
                        Gren.Kernel.HttpServer.addListener server router requestHandler
                    )
    in
    Task.succeed subs


type SelfMsg =
    Never


onSelfMsg : Platform.Router msg SelfMsg -> SelfMsg -> (State msg) -> Task Never (State msg)
onSelfMsg _ _ state =
    Task.succeed state


{-| Subscribe to incoming HTTP requests.
-}
onRequest : Server -> (Request -> Response -> msg) -> Sub msg
onRequest server requestHandler =
    subscription (OnRequestSub { server = server, requestHandler = requestHandler })