{-# 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 a. IO a -> IO (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 (m :: * -> *) a. Monad m => a -> m a
return (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 (m :: * -> *) a. Monad m => a -> m a
return (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")]