    {-# LANGUAGE ScopedTypeVariables, OverloadedStrings, ViewPatterns, RecordWildCards, DeriveFunctor #-}

    module General.Web(
        Input(..),
        Output(..), readInput, server
        ) where

    import Network.Wai.Handler.Warp hiding (Port, Handle)
    import Network.Wai.Handler.WarpTLS

    import Action.CmdLine
    import Network.Wai.Logger
    import Network.Wai
    import Control.DeepSeq
    import Network.HTTP.Types (parseQuery, decodePathSegments)
    import Network.HTTP.Types.Status
    import qualified Data.Text as Text
    import qualified Data.ByteString.Char8 as BS
    import qualified Data.ByteString.Lazy.Char8 as LBS
    import Data.List.Extra
    import Data.Aeson.Encoding
    import Data.Char
    import Data.String
    import Data.Tuple.Extra
    import Data.Maybe
    import Data.Monoid
    import System.FilePath
    import Control.Exception.Extra
    import System.Time.Extra
    import General.Log
    import Prelude
    import qualified Data.ByteString.UTF8 as UTF8

    data Input = Input
        {Input -> [String]
    inputURL :: [String]
        ,Input -> [(String, String)]
    inputArgs :: [(String, String)]
        } deriving Int -> Input -> ShowS
    [Input] -> ShowS
    Input -> String
    (Int -> Input -> ShowS)
    -> (Input -> String) -> ([Input] -> ShowS) -> Show Input
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    showList :: [Input] -> ShowS
    $cshowList :: [Input] -> ShowS
    show :: Input -> String
    $cshow :: Input -> String
    showsPrec :: Int -> Input -> ShowS
    $cshowsPrec :: Int -> Input -> ShowS
    Show

    readInput :: String -> Maybe Input
    readInput :: String -> Maybe Input
    readInput (String -> String -> (String, String)
    forall a. Eq a => [a] -> [a] -> ([a], [a])
    breakOn "?" -> (a :: String
    a,b :: String
    b)) =
      if ([String] -> Bool
    badPath [String]
    path Bool -> Bool -> Bool
    || [(String, String)] -> Bool
    forall b. [(String, b)] -> Bool
    badArgs [(String, String)]
    args) then Maybe Input
    forall a. Maybe a
    Nothing else Input -> Maybe Input
    forall a. a -> Maybe a
    Just (Input -> Maybe Input) -> Input -> Maybe Input
    forall a b. (a -> b) -> a -> b
    $ [String] -> [(String, String)] -> Input
    Input [String]
    path [(String, String)]
    args
      where
        path :: [String]
    path = String -> [String]
    parsePath String
    a
        parsePath :: String -> [String]
    parsePath = (Text -> String) -> [Text] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map Text -> String
    Text.unpack
                  ([Text] -> [String]) -> (String -> [Text]) -> String -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> [Text]
    decodePathSegments
                  (ByteString -> [Text])
    -> (String -> ByteString) -> String -> [Text]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ByteString
    BS.pack
        badPath :: [String] -> Bool
    badPath = (String -> Bool) -> [String] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any ((Char -> Bool) -> String -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == '.')) ([String] -> Bool) -> ([String] -> [String]) -> [String] -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String -> Bool) -> [String] -> [String]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    /= "")
        args :: [(String, String)]
    args = String -> [(String, String)]
    parseArgs String
    b
        parseArgs :: String -> [(String, String)]
    parseArgs = ((ByteString, Maybe ByteString) -> (String, String))
    -> [(ByteString, Maybe ByteString)] -> [(String, String)]
    forall a b. (a -> b) -> [a] -> [b]
    map (ByteString -> String
    UTF8.toString (ByteString -> String)
    -> (Maybe ByteString -> String)
    -> (ByteString, Maybe ByteString)
    -> (String, String)
    forall a a' b b'. (a -> a') -> (b -> b') -> (a, b) -> (a', b')
    *** String -> (ByteString -> String) -> Maybe ByteString -> String
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe "" ByteString -> String
    UTF8.toString)
                  ([(ByteString, Maybe ByteString)] -> [(String, String)])
    -> (String -> [(ByteString, Maybe ByteString)])
    -> String
    -> [(String, String)]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> [(ByteString, Maybe ByteString)]
    parseQuery
                  (ByteString -> [(ByteString, Maybe ByteString)])
    -> (String -> ByteString)
    -> String
    -> [(ByteString, Maybe ByteString)]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ByteString
    UTF8.fromString
        badArgs :: [(String, b)] -> Bool
    badArgs = Bool -> Bool
    not (Bool -> Bool) -> ([(String, b)] -> Bool) -> [(String, b)] -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((String, b) -> Bool) -> [(String, b)] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all ((Char -> Bool) -> String -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Char -> Bool
    isLower (String -> Bool) -> ((String, b) -> String) -> (String, b) -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String, b) -> String
    forall a b. (a, b) -> a
    fst)

    data Output
        = OutputText LBS.ByteString
        | OutputHTML LBS.ByteString
        | OutputJavascript LBS.ByteString
        | OutputJSON Encoding
        | OutputFail LBS.ByteString
        | OutputFile FilePath
          deriving Int -> Output -> ShowS
    [Output] -> ShowS
    Output -> String
    (Int -> Output -> ShowS)
    -> (Output -> String) -> ([Output] -> ShowS) -> Show Output
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    showList :: [Output] -> ShowS
    $cshowList :: [Output] -> ShowS
    show :: Output -> String
    $cshow :: Output -> String
    showsPrec :: Int -> Output -> ShowS
    $cshowsPrec :: Int -> Output -> ShowS
    Show

    -- | Force all the output (no delayed exceptions) and produce bytestrings
    forceBS :: Output -> LBS.ByteString
    forceBS :: Output -> ByteString
    forceBS (OutputText x :: ByteString
    x) = ByteString -> ByteString
    forall a. NFData a => a -> a
    force ByteString
    x
    forceBS (OutputJSON x :: Encoding
    x) = ByteString -> ByteString
    forall a. NFData a => a -> a
    force (ByteString -> ByteString) -> ByteString -> ByteString
    forall a b. (a -> b) -> a -> b
    $ Encoding -> ByteString
    forall a. Encoding' a -> ByteString
    encodingToLazyByteString Encoding
    x
    forceBS (OutputHTML x :: ByteString
    x) = ByteString -> ByteString
    forall a. NFData a => a -> a
    force ByteString
    x
    forceBS (OutputJavascript x :: ByteString
    x) = ByteString -> ByteString
    forall a. NFData a => a -> a
    force ByteString
    x
    forceBS (OutputFail x :: ByteString
    x) = ByteString -> ByteString
    forall a. NFData a => a -> a
    force ByteString
    x
    forceBS (OutputFile x :: String
    x) = String -> ()
    forall a. NFData a => a -> ()
    rnf String
    x () -> ByteString -> ByteString
    forall a b. a -> b -> b
    `seq` ByteString
    LBS.empty

    instance NFData Output where
        rnf :: Output -> ()
    rnf x :: Output
    x = Output -> ByteString
    forceBS Output
    x ByteString -> () -> ()
    forall a b. a -> b -> b
    `seq` ()

    server :: Log -> CmdLine -> (Input -> IO Output) -> IO ()
    server :: Log -> CmdLine -> (Input -> IO Output) -> IO ()
    server log :: Log
    log Server{..} act :: Input -> IO Output
    act = do
        let
            host' :: HostPreference
    host' = String -> HostPreference
    forall a. IsString a => String -> a
    fromString (String -> HostPreference) -> String -> HostPreference
    forall a b. (a -> b) -> a -> b
    $
                      if String
    host String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == "" then
                        if Bool
    local then
                          "127.0.0.1"
                        else
                          "*"
                      else
                        String
    host
            set :: Settings
    set = (SomeException -> Response) -> Settings -> Settings
    setOnExceptionResponse SomeException -> Response
    exceptionResponseForDebug
                (Settings -> Settings)
    -> (Settings -> Settings) -> Settings -> Settings
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . HostPreference -> Settings -> Settings
    setHost HostPreference
    host'
                (Settings -> Settings)
    -> (Settings -> Settings) -> Settings -> Settings
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> Settings -> Settings
    setPort Int
    port (Settings -> Settings) -> Settings -> Settings
    forall a b. (a -> b) -> a -> b
    $
                Settings
    defaultSettings
            runServer :: Application -> IO ()
            runServer :: Application -> IO ()
    runServer = if Bool
    https then TLSSettings -> Settings -> Application -> IO ()
    runTLS (String -> String -> TLSSettings
    tlsSettings String
    cert String
    key) Settings
    set
                                 else Settings -> Application -> IO ()
    runSettings Settings
    set
            secH :: [(HeaderName, ByteString)]
    secH = if Bool
    no_security_headers then []
                                          else [
                 -- The CSP is giving additional instructions to the browser.
                 ("Content-Security-Policy",
                  -- For any content type not specifically enumerated in this CSP
                  -- (e.g. fonts), the only valid origin is the same as the current
                  -- page.
                  "default-src 'self';"
                  -- As an exception to the default rule, allow scripts from jquery
                  -- and the CDN.
                  ByteString -> ByteString -> ByteString
    forall a. Semigroup a => a -> a -> a
    <> " script-src 'self' https://code.jquery.com/ https://rawcdn.githack.com;"
                  -- As an exception to the default rule, allow stylesheets from
                  -- the CDN. TODO: for now, we are also enabling inline styles,
                  -- because it the chosen plugin uses them.
                  ByteString -> ByteString -> ByteString
    forall a. Semigroup a => a -> a -> a
    <> " style-src 'self' 'unsafe-inline' https://rawcdn.githack.com;"
                  -- As an exception to the default rule, allow images from the
                  -- CDN.
                  ByteString -> ByteString -> ByteString
    forall a. Semigroup a => a -> a -> a
    <> " img-src 'self' https://rawcdn.githack.com;"
                  -- Only allow this request in an iframe if the containing page
                  -- has the same origin.
                  ByteString -> ByteString -> ByteString
    forall a. Semigroup a => a -> a -> a
    <> " frame-ancestors 'self';"
                  -- Forms are only allowed to target addresses under the same
                  -- origin as the page.
                  ByteString -> ByteString -> ByteString
    forall a. Semigroup a => a -> a -> a
    <> " form-action 'self';"
                  -- Any request originating from this page and specifying http as
                  -- its protocol will be automatically upgraded to https.
                  ByteString -> ByteString -> ByteString
    forall a. Semigroup a => a -> a -> a
    <> " upgrade-insecure-requests;"
                  -- Do not display http content if the page was loaded under
                  -- https.
                  ByteString -> ByteString -> ByteString
    forall a. Semigroup a => a -> a -> a
    <> " block-all-mixed-content"),

                 -- Tells the browser this web page should not be rendered inside a
                 -- frame, except if the framing page comes from the same origin
                 -- (i.e. DNS name + port). This is to thwart invisible, keylogging
                 -- framing pages.
                 ("X-Frame-Options", "sameorigin"),

                 -- Tells browsers to trust the Content-Type header and not try to
                 -- otherwise guess at response types. In particular, prevents
                 -- dangerous browser behaviour that would execute a file loaded
                 -- from a <script> or <style> tag despite not having a
                 -- text/javascript or text/css Content-Type.
                 ("X-Content-Type-Options", "nosniff"),

                 -- Browser should try to detect "reflected" XSS attacks, where
                 -- some suspicious payload of the request appears in the response.
                 -- How browsers do that is unspecified. On detection, browser
                 -- should block the page from rendering at all.
                 ("X-XSS-Protection", "1; mode=block"),

                 -- Do not include referrer information if user-agent generates a
                 -- request from an HTTPS page to an HTTP one. Note: this is
                 -- technically redundant as this should be the browser default
                 -- behaviour.
                 ("Referrer-Policy", "no-referrer-when-downgrade"),

                 -- Strict Transport Security (aka HSTS) tells the browser that,
                 -- from now on and until max-age seconds have passed, it should
                 -- never try to connect to this domain name through unprotected
                 -- HTTP. The browser will automatically upgrade any HTTP request
                 -- to this domain name to HTTPS, client side, before any network
                 -- call happens.
                 ("Strict-Transport-Security", "max-age=31536000; includeSubDomains")]

        Log -> String -> IO ()
    logAddMessage Log
    log (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ "Server starting on port " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    port String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ " and host/IP " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ HostPreference -> String
    forall a. Show a => a -> String
    show HostPreference
    host'

        Application -> IO ()
    runServer (Application -> IO ()) -> Application -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \req :: Request
    req reply :: Response -> IO ResponseReceived
    reply -> do
            let pq :: String
    pq = ByteString -> String
    BS.unpack (ByteString -> String) -> ByteString -> String
    forall a b. (a -> b) -> a -> b
    $ Request -> ByteString
    rawPathInfo Request
    req ByteString -> ByteString -> ByteString
    forall a. Semigroup a => a -> a -> a
    <> Request -> ByteString
    rawQueryString Request
    req
            String -> IO ()
    putStrLn String
    pq
            (time :: Seconds
    time, res :: Either String (Output, ByteString)
    res) <- IO (Either String (Output, ByteString))
    -> IO (Seconds, Either String (Output, ByteString))
    forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
    duration (IO (Either String (Output, ByteString))
     -> IO (Seconds, Either String (Output, ByteString)))
    -> IO (Either String (Output, ByteString))
    -> IO (Seconds, Either String (Output, ByteString))
    forall a b. (a -> b) -> a -> b
    $ case String -> Maybe Input
    readInput String
    pq of
                Nothing -> Either String (Output, ByteString)
    -> IO (Either String (Output, ByteString))
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Either String (Output, ByteString)
     -> IO (Either String (Output, ByteString)))
    -> Either String (Output, ByteString)
    -> IO (Either String (Output, ByteString))
    forall a b. (a -> b) -> a -> b
    $ (Output, ByteString) -> Either String (Output, ByteString)
    forall a b. b -> Either a b
    Right (ByteString -> Output
    OutputFail "", String -> ByteString
    LBS.pack (String -> ByteString) -> String -> ByteString
    forall a b. (a -> b) -> a -> b
    $ "Bad URL: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    pq)
                Just pay :: Input
    pay ->
                    (SomeException -> IO (Either String (Output, ByteString)))
    -> IO (Either String (Output, ByteString))
    -> IO (Either String (Output, ByteString))
    forall a. (SomeException -> IO a) -> IO a -> IO a
    handle_ ((String -> Either String (Output, ByteString))
    -> IO String -> IO (Either String (Output, ByteString))
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap String -> Either String (Output, ByteString)
    forall a b. a -> Either a b
    Left (IO String -> IO (Either String (Output, ByteString)))
    -> (SomeException -> IO String)
    -> SomeException
    -> IO (Either String (Output, ByteString))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . SomeException -> IO String
    forall e. Show e => e -> IO String
    showException) (IO (Either String (Output, ByteString))
     -> IO (Either String (Output, ByteString)))
    -> IO (Either String (Output, ByteString))
    -> IO (Either String (Output, ByteString))
    forall a b. (a -> b) -> a -> b
    $ do
                        Output
    s <- Input -> IO Output
    act Input
    pay; ByteString
    bs <- ByteString -> IO ByteString
    forall a. a -> IO a
    evaluate (ByteString -> IO ByteString) -> ByteString -> IO ByteString
    forall a b. (a -> b) -> a -> b
    $ Output -> ByteString
    forceBS Output
    s; Either String (Output, ByteString)
    -> IO (Either String (Output, ByteString))
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Either String (Output, ByteString)
     -> IO (Either String (Output, ByteString)))
    -> Either String (Output, ByteString)
    -> IO (Either String (Output, ByteString))
    forall a b. (a -> b) -> a -> b
    $ (Output, ByteString) -> Either String (Output, ByteString)
    forall a b. b -> Either a b
    Right (Output
    s, ByteString
    bs)
            Log -> String -> String -> Seconds -> Maybe String -> IO ()
    logAddEntry Log
    log (SockAddr -> String
    showSockAddr (SockAddr -> String) -> SockAddr -> String
    forall a b. (a -> b) -> a -> b
    $ Request -> SockAddr
    remoteHost Request
    req) String
    pq Seconds
    time ((String -> Maybe String)
    -> ((Output, ByteString) -> Maybe String)
    -> Either String (Output, ByteString)
    -> Maybe String
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either String -> Maybe String
    forall a. a -> Maybe a
    Just (Maybe String -> (Output, ByteString) -> Maybe String
    forall a b. a -> b -> a
    const Maybe String
    forall a. Maybe a
    Nothing) Either String (Output, ByteString)
    res)
            case Either String (Output, ByteString)
    res of
                Left s :: String
    s -> Response -> IO ResponseReceived
    reply (Response -> IO ResponseReceived)
    -> Response -> IO ResponseReceived
    forall a b. (a -> b) -> a -> b
    $ Status -> [(HeaderName, ByteString)] -> ByteString -> Response
    responseLBS Status
    status500 [] (ByteString -> Response) -> ByteString -> Response
    forall a b. (a -> b) -> a -> b
    $ String -> ByteString
    LBS.pack String
    s
                Right (v :: Output
    v, bs :: ByteString
    bs) -> Response -> IO ResponseReceived
    reply (Response -> IO ResponseReceived)
    -> Response -> IO ResponseReceived
    forall a b. (a -> b) -> a -> b
    $ case Output
    v of
                    OutputFile file :: String
    file -> Status
    -> [(HeaderName, ByteString)]
    -> String
    -> Maybe FilePart
    -> Response
    responseFile Status
    status200
                        ([("content-type",ByteString
    c) | Just c :: ByteString
    c <- [String -> [(String, ByteString)] -> Maybe ByteString
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup (ShowS
    takeExtension String
    file) [(String, ByteString)]
    contentType]] [(HeaderName, ByteString)]
    -> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
    forall a. [a] -> [a] -> [a]
    ++ [(HeaderName, ByteString)]
    secH) String
    file Maybe FilePart
    forall a. Maybe a
    Nothing
                    OutputText{} -> Status -> [(HeaderName, ByteString)] -> ByteString -> Response
    responseLBS Status
    status200 (("content-type","text/plain") (HeaderName, ByteString)
    -> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
    forall a. a -> [a] -> [a]
    : [(HeaderName, ByteString)]
    secH) ByteString
    bs
                    OutputJSON{} -> Status -> [(HeaderName, ByteString)] -> ByteString -> Response
    responseLBS Status
    status200 (("content-type","application/json") (HeaderName, ByteString)
    -> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
    forall a. a -> [a] -> [a]
    : ("access-control-allow-origin","*") (HeaderName, ByteString)
    -> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
    forall a. a -> [a] -> [a]
    : [(HeaderName, ByteString)]
    secH) ByteString
    bs
                    OutputFail{} -> Status -> [(HeaderName, ByteString)] -> ByteString -> Response
    responseLBS Status
    status400 (("content-type","text/plain") (HeaderName, ByteString)
    -> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
    forall a. a -> [a] -> [a]
    : [(HeaderName, ByteString)]
    secH) ByteString
    bs
                    OutputHTML{} -> Status -> [(HeaderName, ByteString)] -> ByteString -> Response
    responseLBS Status
    status200 (("content-type","text/html") (HeaderName, ByteString)
    -> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
    forall a. a -> [a] -> [a]
    : [(HeaderName, ByteString)]
    secH) ByteString
    bs
                    OutputJavascript{} -> Status -> [(HeaderName, ByteString)] -> ByteString -> Response
    responseLBS Status
    status200 (("content-type","text/javascript") (HeaderName, ByteString)
    -> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
    forall a. a -> [a] -> [a]
    : [(HeaderName, ByteString)]
    secH) ByteString
    bs

    contentType :: [(String, ByteString)]
    contentType = [(".html","text/html"),(".css","text/css"),(".js","text/javascript")]