{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskellQuotes #-}

{- | Miscellaneous HTTP Utilities. -}
module OM.HTTP (
  runTlsRedirect,
  hstsDirective,
  requestLogging,
  setServer,
  insertResponseHeaderIfMissing,
  overwriteResponseHeader,
  staticSite,
  logExceptionsAndContinue,
  sshConnect,
  staticPage,
  defaultIndex,
  BearerToken(..),
  emptyApp,
) where


import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (concurrently_)
import Control.Exception (try)
import Control.Exception.Safe (SomeException, bracket, finally, throwM, tryAny)
import Control.Monad (join, void)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Logger.Aeson
  ( LoggingT(runLoggingT), Message((:#)), (.=), Loc, LogLevel, LogSource, LogStr
  , MonadLoggerIO, logError, logInfo
  )
import Data.Base64.Types (extractBase64)
import Data.ByteString (ByteString)
import Data.ByteString.Base64 (encodeBase64)
import Data.List ((\\))
import Data.Maybe (catMaybes)
import Data.String (IsString(fromString))
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8')
import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)
import Data.UUID (UUID)
import Data.UUID.V1 (nextUUID)
import Data.Version (Version, showVersion)
import Language.Haskell.TH (Code(examineCode), Q, TExp, runIO)
import Language.Haskell.TH.Syntax (addDependentFile)
import Network.HTTP.Types
  ( Status(statusCode, statusMessage), Header, internalServerError500
  , methodNotAllowed405, movedPermanently301, ok200, status404
  )
import Network.Mime (defaultMimeLookup)
import Network.Socket
  ( AddrInfo(addrAddress), Family(AF_INET), SocketType(Stream), Socket, close
  , connect, defaultProtocol, getAddrInfo, socket
  )
import Network.Socket.ByteString (recv, sendAll)
import Network.Wai
  ( Request
    ( isSecure, pathInfo, rawPathInfo, rawQueryString, remoteHost
    , requestHeaders, requestMethod
    )
  , Application, Middleware, Response, ResponseReceived, mapResponseHeaders
  , responseLBS, responseRaw, responseStatus
  )
import Network.Wai.Handler.Warp (run)
import OM.Show (showt)
import Prelude
  ( Applicative(pure), Either(Left, Right), Eq((/=), (==))
  , Foldable(elem, foldr), Functor(fmap), Maybe(Just, Nothing)
  , Monad((>>), (>>=), return), MonadFail(fail), Monoid(mempty)
  , RealFrac(truncate), Semigroup((<>)), Show(show), Traversable(mapM), ($)
  , (++), (.), (<$>), (=<<), FilePath, IO, Int, String, concat, drop, filter
  , fst, id, mapM_, otherwise, putStrLn, seq, zip
  )
import Servant.API (ToHttpApiData(toUrlPiece))
import System.Directory (getDirectoryContents)
import System.FilePath.Posix ((</>), combine)
import System.Posix.Files (getFileStatus, isDirectory, isRegularFile)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BSL8
import qualified Data.CaseInsensitive as CI
import qualified Data.Text as T


{- |
  Runs a web server on port 80, that redirects to the given url. Does
  request logging, and sets the HSTS Directive header, and in the unlikely
  event of excptions it will also catch and log them.
-}
runTlsRedirect
  :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) {- ^ Logging backend. -}
  -> ByteString {- ^ Server name. -}
  -> Version {- ^ Server version. -}
  -> ByteString {- ^ Target URL. -}
  -> IO ()
runTlsRedirect :: (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> ByteString -> Version -> ByteString -> IO ()
runTlsRedirect Loc -> Text -> LogLevel -> LogStr -> IO ()
logging ByteString
serverName Version
serverVersion ByteString
url =
  Int -> Application -> IO ()
run Int
80
    (Application -> IO ())
-> (Application -> Application) -> Application -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Application -> Application
requestLogging Loc -> Text -> LogLevel -> LogStr -> IO ()
logging
    (Application -> Application)
-> (Application -> Application) -> Application -> Application
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Version -> Application -> Application
setServer ByteString
serverName Version
serverVersion
    (Application -> Application)
-> (Application -> Application) -> Application -> Application
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Application -> Application
hstsDirective NominalDiffTime
600
    (Application -> Application)
-> (Application -> Application) -> Application -> Application
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Application -> Application
logExceptionsAndContinue Loc -> Text -> LogLevel -> LogStr -> IO ()
logging
    (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Application
tlsRedirect ByteString
url


{- |
  Inject the HSTS directives, see
  https://en.wikipedia.org/wiki/HTTP_Strict_Transport_Security.
-}
hstsDirective :: NominalDiffTime -> Middleware
hstsDirective :: NominalDiffTime -> Application -> Application
hstsDirective NominalDiffTime
age = Header -> Application -> Application
insertResponseHeaderIfMissing Header
header
  where
    header :: Header
    header :: Header
header =
      (HeaderName
"Strict-Transport-Security", ByteString
"max-age=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> ByteString
forall a b. (Show a, IsString b) => a -> b
showt (NominalDiffTime -> Int
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate NominalDiffTime
age :: Int))


{- | Insert a response header only if it has not already been inserted. -}
insertResponseHeaderIfMissing :: Header -> Middleware
insertResponseHeaderIfMissing :: Header -> Application -> Application
insertResponseHeaderIfMissing (HeaderName
name, ByteString
val) Application
app Request
req Response -> IO ResponseReceived
respond =
    Application
app Request
req (Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> (Response -> Response) -> Response -> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ResponseHeaders -> ResponseHeaders) -> Response -> Response
mapResponseHeaders ResponseHeaders -> ResponseHeaders
doInsert)
  where
    doInsert :: [Header] -> [Header]
    doInsert :: ResponseHeaders -> ResponseHeaders
doInsert ResponseHeaders
headers
      | HeaderName
name HeaderName -> [HeaderName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Header -> HeaderName
forall a b. (a, b) -> a
fst (Header -> HeaderName) -> ResponseHeaders -> [HeaderName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponseHeaders
headers) = ResponseHeaders
headers
      | Bool
otherwise = (HeaderName
name, ByteString
val)Header -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
:ResponseHeaders
headers


{- |
  TLS redirect. An 'Application' that redirects unsecured requests to
  the secure HTTPS site.
-}
tlsRedirect :: ByteString -> Application
tlsRedirect :: ByteString -> Application
tlsRedirect ByteString
url Request
_req Response -> IO ResponseReceived
respond = Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$
  Status -> ResponseHeaders -> ByteString -> Response
responseLBS
    Status
movedPermanently301
    [
      (HeaderName
"Location", ByteString
url),
      (HeaderName
"Content-Type", ByteString
"text/html")
    ]
    (
      ByteString
"<html>\
        \<head>\
        \</head>\
        \<body>\
          \Please use our secure site,\
          \<a href=\"" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
BSL.fromStrict ByteString
url ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\">here</a>\
        \</body>\
      \</html>"
    )


{- | Set the @Server:@ header. -}
setServer :: ByteString -> Version -> Middleware
setServer :: ByteString -> Version -> Application -> Application
setServer ByteString
serviceName Version
version =
    Header -> Application -> Application
overwriteResponseHeader (HeaderName
"Server", ByteString
serverValue)
  where
    {- | The value of the @Server:@ header. -}
    serverValue :: ByteString
serverValue = ByteString
serviceName ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> FilePath -> ByteString
forall a. IsString a => FilePath -> a
fromString (Version -> FilePath
showVersion Version
version)


{- |
  Inserts a response header, clobbering any and all existing values for
  the given header.
-}
overwriteResponseHeader :: Header -> Middleware
overwriteResponseHeader :: Header -> Application -> Application
overwriteResponseHeader (HeaderName
name, ByteString
value) Application
app Request
req Response -> IO ResponseReceived
respond =
    Application
app Request
req (Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> (Response -> Response) -> Response -> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ResponseHeaders -> ResponseHeaders) -> Response -> Response
mapResponseHeaders ResponseHeaders -> ResponseHeaders
go)
  where
    go :: [Header] -> [Header]
    go :: ResponseHeaders -> ResponseHeaders
go ResponseHeaders
headers =
      (HeaderName
name, ByteString
value) Header -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: (Header -> Bool) -> ResponseHeaders -> ResponseHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter ((HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
name) (HeaderName -> Bool) -> (Header -> HeaderName) -> Header -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header -> HeaderName
forall a b. (a, b) -> a
fst) ResponseHeaders
headers


{- |
  Logs an HTTP request by emitting two log messages. The first messages
  logs that the request has begun. The second messages logs the status
  result and timing of the request once it is finished.

  > {"text":"Starting request: GET /api/me","meta":{..<request details>..}}
  > {"text":"Request complete: GET /api/me","meta":{"status":"200 OK","time":"0.000370671s"}}

  This can help debugging requests that hang or crash for whatever reason.
-}
requestLogging
  :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
  -> Middleware
requestLogging :: (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Application -> Application
requestLogging Loc -> Text -> LogLevel -> LogStr -> IO ()
logging Application
app Request
req Response -> IO ResponseReceived
respond =
    (LoggingT IO ResponseReceived
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> IO ResponseReceived
forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
`runLoggingT` Loc -> Text -> LogLevel -> LogStr -> IO ()
logging) (LoggingT IO ResponseReceived -> IO ResponseReceived)
-> LoggingT IO ResponseReceived -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ do
      Message -> LoggingT IO ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logInfo (Message -> LoggingT IO ()) -> Message -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Starting request: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reqStr Text -> [SeriesElem] -> Message
:#
        [ Key
"method" Key -> Text -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeUtf8Safe (Request -> ByteString
requestMethod Request
req)
        , Key
"path" Key -> Text -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeUtf8Safe (Request -> ByteString
rawPathInfo Request
req)
        , Key
"query" Key -> Text -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeUtf8Safe (Request -> ByteString
rawQueryString Request
req)
        , Key
"secure" Key -> Bool -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Request -> Bool
isSecure Request
req
        , Key
"remote_host" Key -> FilePath -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SockAddr -> FilePath
forall a. Show a => a -> FilePath
show (Request -> SockAddr
remoteHost Request
req)
        , Key
"headers" Key -> [Text] -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=
            (Header -> Text) -> ResponseHeaders -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
              (\(HeaderName
name, ByteString
val) ->
                ByteString -> Text
decodeUtf8Safe (HeaderName -> ByteString
forall s. CI s -> s
CI.original HeaderName
name)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
decodeUtf8Safe ByteString
val
              )
              (Request -> ResponseHeaders
requestHeaders Request
req)
        ]
      now <- IO UTCTime -> LoggingT IO UTCTime
forall a. IO a -> LoggingT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      liftIO (try (app req (loggingRespond now))) >>= \case
        Left SomeException
err -> do
          Message -> LoggingT IO ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logError (Message -> LoggingT IO ()) -> Message -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$
            Text
"`app` failed with exception. The exception will be re-thrown." Text -> [SeriesElem] -> Message
:#
            [ Key
"exception" Key -> FilePath -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SomeException -> FilePath
forall a. Show a => a -> FilePath
show (SomeException
err :: SomeException)
            ]
          SomeException -> LoggingT IO ResponseReceived
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwM SomeException
err
        Right ResponseReceived
val -> ResponseReceived -> LoggingT IO ResponseReceived
forall a. a -> LoggingT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseReceived
val
  where
    {- | Delegate to the underlying responder, and do some logging. -}
    loggingRespond :: UTCTime -> Response -> IO ResponseReceived
    loggingRespond :: UTCTime -> Response -> IO ResponseReceived
loggingRespond UTCTime
start Response
response =
      (LoggingT IO ResponseReceived
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> IO ResponseReceived
forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
`runLoggingT` Loc -> Text -> LogLevel -> LogStr -> IO ()
logging) (LoggingT IO ResponseReceived -> IO ResponseReceived)
-> LoggingT IO ResponseReceived -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ do
        {-
          Execute the underlying responder first so we get an accurate
          measurement of the request duration.
        -}
        ack <- IO (Either SomeException ResponseReceived)
-> LoggingT IO (Either SomeException ResponseReceived)
forall a. IO a -> LoggingT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> IO (Either SomeException ResponseReceived)
forall e a. Exception e => IO a -> IO (Either e a)
try (Response -> IO ResponseReceived
respond Response
response)) LoggingT IO (Either SomeException ResponseReceived)
-> (Either SomeException ResponseReceived
    -> LoggingT IO ResponseReceived)
-> LoggingT IO ResponseReceived
forall a b. LoggingT IO a -> (a -> LoggingT IO b) -> LoggingT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left SomeException
err -> do
            Message -> LoggingT IO ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logError (Message -> LoggingT IO ()) -> Message -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$
              Text
"`respond` failed with exception. The exception will be re-thrown." Text -> [SeriesElem] -> Message
:#
              [Key
"exception" Key -> FilePath -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SomeException -> FilePath
forall a. Show a => a -> FilePath
show (SomeException
err :: SomeException)]
            SomeException -> LoggingT IO ResponseReceived
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwM SomeException
err
          Right ResponseReceived
ack -> ResponseReceived -> LoggingT IO ResponseReceived
forall a. a -> LoggingT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseReceived
ack
        now <- ack `seq` liftIO getCurrentTime
        logInfo $ "Request complete: " <> reqStr :#
          [ "status" .= showStatus (responseStatus response)
          , "time" .= show (diffUTCTime now start)
          ]
        return ack

    {- | A Text representation of the request, suitable for logging. -}
    reqStr :: Text
    reqStr :: Text
reqStr =
      ByteString -> Text
decodeUtf8Safe
        (Request -> ByteString
requestMethod Request
req ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
rawPathInfo Request
req ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
rawQueryString Request
req)

    {- |
      @instance Show Status@ shows the Haskell structure, which is
      not suitable for logging.
    -}
    showStatus :: Status -> Text
    showStatus :: Status -> Text
showStatus Status
stat =
      (Int -> Text
forall a b. (Show a, IsString b) => a -> b
showt (Int -> Text) -> (Status -> Int) -> Status -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> Int
statusCode) Status
stat Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (ByteString -> Text
decodeUtf8Safe (ByteString -> Text) -> (Status -> ByteString) -> Status -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> ByteString
statusMessage) Status
stat


{- |
  Logs all exceptions, and returns a 500 Internal Server error.

  This is useful because your wai framework won't always do what you
  expect when it encounters random exceptions. For instance, an exception
  thrown in IO may cause functionality of higher-level middlewares to be
  bypassed unless they know how to catch and re-throw exceptions (making
  them more complicated). This middleware explicitly will not re-throw
  exceptions, unless those exceptions were encountered after the headers
  have already been sent, e.g. when using 'Network.Wai.StreamingBody'.

  What it will do is generate a unique id for the exception and print
  that ID, so you can easily find it in the logs.
-}
logExceptionsAndContinue
  :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) {- ^ Logging backend. -}
  -> Middleware
logExceptionsAndContinue :: (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Application -> Application
logExceptionsAndContinue Loc -> Text -> LogLevel -> LogStr -> IO ()
logging Application
app Request
req Response -> IO ResponseReceived
respond = (LoggingT IO ResponseReceived
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> IO ResponseReceived
forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
`runLoggingT` Loc -> Text -> LogLevel -> LogStr -> IO ()
logging) (LoggingT IO ResponseReceived -> IO ResponseReceived)
-> LoggingT IO ResponseReceived -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$
    LoggingT IO ResponseReceived
-> LoggingT IO (Either SomeException ResponseReceived)
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> m (Either SomeException a)
tryAny (IO ResponseReceived -> LoggingT IO ResponseReceived
forall a. IO a -> LoggingT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Application
app Request
req Response -> IO ResponseReceived
loggingRespond)) LoggingT IO (Either SomeException ResponseReceived)
-> (Either SomeException ResponseReceived
    -> LoggingT IO ResponseReceived)
-> LoggingT IO ResponseReceived
forall a b. LoggingT IO a -> (a -> LoggingT IO b) -> LoggingT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Right ResponseReceived
ack -> ResponseReceived -> LoggingT IO ResponseReceived
forall a. a -> LoggingT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
ack
      Left SomeException
err -> do
        uuid <- SomeException -> LoggingT IO UUID
forall (m :: * -> *). MonadLoggerIO m => SomeException -> m UUID
logProblem SomeException
err
        liftIO $ respond (errResponse uuid)
  where
    errResponse :: UUID -> Response
    errResponse :: UUID -> Response
errResponse UUID
uuid =
      Status -> ResponseHeaders -> ByteString -> Response
responseLBS
        Status
internalServerError500
        [(HeaderName
"Content-Type", ByteString
"text/plain")]
        (ByteString
"Internal Server Error. Error ID: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> UUID -> ByteString
forall a b. (Show a, IsString b) => a -> b
showt UUID
uuid)

    getUUID :: (MonadIO m) => m UUID
    getUUID :: forall (m :: * -> *). MonadIO m => m UUID
getUUID = IO (Maybe UUID) -> m (Maybe UUID)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Maybe UUID)
nextUUID m (Maybe UUID) -> (Maybe UUID -> m UUID) -> m UUID
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe UUID
Nothing -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO ()
threadDelay Int
1000) m () -> m UUID -> m UUID
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m UUID
forall (m :: * -> *). MonadIO m => m UUID
getUUID
      Just UUID
uuid -> UUID -> m UUID
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return UUID
uuid

    loggingRespond :: Response -> IO ResponseReceived
    loggingRespond :: Response -> IO ResponseReceived
loggingRespond Response
response = (LoggingT IO ResponseReceived
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> IO ResponseReceived
forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
`runLoggingT` Loc -> Text -> LogLevel -> LogStr -> IO ()
logging) (LoggingT IO ResponseReceived -> IO ResponseReceived)
-> LoggingT IO ResponseReceived -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$
      LoggingT IO ResponseReceived
-> LoggingT IO (Either SomeException ResponseReceived)
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> m (Either SomeException a)
tryAny (IO ResponseReceived -> LoggingT IO ResponseReceived
forall a. IO a -> LoggingT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Response -> IO ResponseReceived
respond Response
response)) LoggingT IO (Either SomeException ResponseReceived)
-> (Either SomeException ResponseReceived
    -> LoggingT IO ResponseReceived)
-> LoggingT IO ResponseReceived
forall a b. LoggingT IO a -> (a -> LoggingT IO b) -> LoggingT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right ResponseReceived
ack -> ResponseReceived -> LoggingT IO ResponseReceived
forall a. a -> LoggingT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
ack
        Left SomeException
err -> do
          LoggingT IO UUID -> LoggingT IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LoggingT IO UUID -> LoggingT IO ())
-> LoggingT IO UUID -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> LoggingT IO UUID
forall (m :: * -> *). MonadLoggerIO m => SomeException -> m UUID
logProblem SomeException
err
          SomeException -> LoggingT IO ResponseReceived
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwM SomeException
err

    logProblem :: (MonadLoggerIO m) => SomeException -> m UUID
    logProblem :: forall (m :: * -> *). MonadLoggerIO m => SomeException -> m UUID
logProblem SomeException
err = do
      uuid <- m UUID
forall (m :: * -> *). MonadIO m => m UUID
getUUID
      logError $ "Internal Server Error" :#
        [ "exception" .= show err
        , "id" .= uuid
        ]
      return uuid


{- |
  'Middleware' that provides an HTTP @CONNECT@ passthrough to the local
  ssh port. Useful primarily for bypassing content-inspection firewalls.
-}
sshConnect :: Middleware
sshConnect :: Application -> Application
sshConnect Application
app Request
req Response -> IO ResponseReceived
respond =
    case Request -> ByteString
requestMethod Request
req of
      ByteString
"CONNECT" ->
        Response -> IO ResponseReceived
respond ((IO ByteString -> (ByteString -> IO ()) -> IO ())
-> Response -> Response
responseRaw IO ByteString -> (ByteString -> IO ()) -> IO ()
connProxy (Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
methodNotAllowed405 [] ByteString
""))
      ByteString
_ -> Application
app Request
req Response -> IO ResponseReceived
respond
  where
    {- |
      Open a connection to the local ssh port and mediate the traffic between
      that service and the client.
    -}
    connProxy :: IO ByteString -> (ByteString -> IO ()) -> IO ()
    connProxy :: IO ByteString -> (ByteString -> IO ()) -> IO ()
connProxy IO ByteString
read_ ByteString -> IO ()
write =
      IO Socket -> (Socket -> IO ()) -> (Socket -> IO ()) -> IO ()
forall (m :: * -> *) a b c.
(HasCallStack, MonadMask m) =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
        (Family -> SocketType -> ProtocolNumber -> IO Socket
socket Family
AF_INET SocketType
Stream ProtocolNumber
defaultProtocol)
        (\Socket
so ->  Socket -> IO ()
close Socket
so IO () -> IO () -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` ByteString -> IO ()
write ByteString
"")
        (\Socket
so -> do
          Socket -> SockAddr -> IO ()
connect Socket
so (SockAddr -> IO ()) -> IO SockAddr -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
            (
              Maybe AddrInfo -> Maybe FilePath -> Maybe FilePath -> IO [AddrInfo]
forall (t :: * -> *).
GetAddrInfo t =>
Maybe AddrInfo
-> Maybe FilePath -> Maybe FilePath -> IO (t AddrInfo)
getAddrInfo Maybe AddrInfo
forall a. Maybe a
Nothing (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"127.0.0.1") (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"22") IO [AddrInfo] -> ([AddrInfo] -> IO SockAddr) -> IO SockAddr
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                [] -> FilePath -> IO SockAddr
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"Address not found: 127.0.0.1:22"
                AddrInfo
sa:[AddrInfo]
_ -> SockAddr -> IO SockAddr
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrInfo -> SockAddr
addrAddress AddrInfo
sa)
            )
          IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
concurrently_
            (Socket -> IO ByteString -> IO ()
pipeInbound Socket
so IO ByteString
read_)
            (Socket -> (ByteString -> IO ()) -> IO ()
pipeOutbound Socket
so ByteString -> IO ()
write)
        )

    {- | Forward data coming from the client, going to the ssh service. -}
    pipeInbound :: Socket -> IO ByteString -> IO ()
    pipeInbound :: Socket -> IO ByteString -> IO ()
pipeInbound Socket
so IO ByteString
read_ = do
      bytes <- IO ByteString
read_
      if BS.null bytes
        then return ()
        else do
          sendAll so bytes
          pipeInbound so read_

    {- | Forward data coming from the ssh service, going to the client. -}
    pipeOutbound :: Socket -> (ByteString -> IO ()) -> IO ()
    pipeOutbound :: Socket -> (ByteString -> IO ()) -> IO ()
pipeOutbound Socket
so ByteString -> IO ()
write = do
      bytes <- Socket -> Int -> IO ByteString
recv Socket
so Int
4096
      write bytes
      if BS.null bytes
        then return ()
        else pipeOutbound so write


{- | Serve a static page at the given 'pathInfo'. -}
staticPage
  :: [Text] {- ^ The path info. -}
  -> ByteString {- ^ The content type. -}
  -> BSL.ByteString {- ^ The response body content. -}
  -> Middleware
staticPage :: [Text] -> ByteString -> ByteString -> Application -> Application
staticPage [Text]
path ByteString
ct ByteString
bytes Application
app Request
req Response -> IO ResponseReceived
respond =
  if Request -> [Text]
pathInfo Request
req [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text]
path
    then Response -> IO ResponseReceived
respond (Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
ok200 [(HeaderName
"Content-Type", ByteString
ct)] ByteString
bytes)
    else Application
app Request
req Response -> IO ResponseReceived
respond


{- | Rewrite: "\/" -> "/index.html". -}
defaultIndex :: Middleware
defaultIndex :: Application -> Application
defaultIndex Application
app Request
request Response -> IO ResponseReceived
respond =
  case Request -> [Text]
pathInfo Request
request of
    [] -> Application
app Request
request {pathInfo = ["index.html"]} Response -> IO ResponseReceived
respond
    [Text]
_ -> Application
app Request
request Response -> IO ResponseReceived
respond


{- |
  A bearer token, which is an instance of the necessary type classes to
  be useful as a servant header value.
-}
newtype BearerToken = BearerToken {
    BearerToken -> Text
unBearerToken :: Text
  }
instance ToHttpApiData BearerToken where
  toUrlPiece :: BearerToken -> Text
toUrlPiece BearerToken
t = Text
"Bearer " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BearerToken -> Text
unBearerToken BearerToken
t


{- |
  The Template-Haskell splice @$$(staticSite dir)@ will build a
  'Middleware' that serves a set of static files determined at
  compile time, or else passes the request to the underlying
  'Network.Wai.Application'.

  All files under @dir@ will be served relative to the root path of
  your web server, so the file @\<dir\>\/foo\/bar.html@ will be served at
  @http://your-web-site.com/foo/bar.html@

  The content-type of the files being served will be guessed using
  'defaultMimeLookup'.
-}
staticSite :: FilePath -> Q (TExp Middleware)
staticSite :: FilePath -> Q (TExp (Application -> Application))
staticSite FilePath
baseDir = Q (Q (TExp (Application -> Application)))
-> Q (TExp (Application -> Application))
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Q (Q (TExp (Application -> Application)))
 -> Q (TExp (Application -> Application)))
-> (IO (Q (TExp (Application -> Application)))
    -> Q (Q (TExp (Application -> Application))))
-> IO (Q (TExp (Application -> Application)))
-> Q (TExp (Application -> Application))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Q (TExp (Application -> Application)))
-> Q (Q (TExp (Application -> Application)))
forall a. IO a -> Q a
runIO (IO (Q (TExp (Application -> Application)))
 -> Q (TExp (Application -> Application)))
-> IO (Q (TExp (Application -> Application)))
-> Q (TExp (Application -> Application))
forall a b. (a -> b) -> a -> b
$ do
    files <- IO [(FilePath, FilePath)]
readStaticFiles
    mapM_ (printResource . fst) files
    return $ mapM_ (addDependentFile . ((baseDir ++ "/") ++) . fst) files >> examineCode [||
        let
          {- |
            Build a middleware that serves a single static file path, or
            delegates to the underlying application.
          -}
          static :: (FilePath, String) -> Middleware
          static (FilePath
filename, FilePath
content) Application
app Request
req Response -> IO ResponseReceived
respond =
            let
              {- | Guess the content type of the static file. -}
              ct :: ByteString
              ct :: ByteString
ct =
                Text -> ByteString
defaultMimeLookup
                (b -> c) -> (a -> b) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> a
forall a. IsString a => FilePath -> a
fromString
                (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ FilePath
filename
            in
              if Request -> [Text]
pathInfo Request
req a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== (Char -> Bool) -> Text -> [Text]
T.split (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (FilePath -> Text
T.pack FilePath
filename)
                then
                  Response -> IO ResponseReceived
respond (
                      Status -> ResponseHeaders -> ByteString -> Response
responseLBS
                        Status
ok200
                        [(a
"content-type", ByteString
ct)]
                        (FilePath -> ByteString
BSL8.pack FilePath
content)
                    )
                else Application
app Request
req Response -> IO ResponseReceived
respond
        in
          foldr ((.) . static) id files :: Middleware
      ||]
  where
    printResource :: String -> IO ()
    printResource :: FilePath -> IO ()
printResource FilePath
file =
      FilePath -> IO ()
putStrLn (FilePath
"Generating static resource for: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
file)

    {- | Reads the static files that make up the admin user interface. -}
    readStaticFiles :: IO [(FilePath, String)]
    readStaticFiles :: IO [(FilePath, FilePath)]
readStaticFiles =
      let
        findAll :: FilePath -> IO [FilePath]
        findAll :: FilePath -> IO [FilePath]
findAll FilePath
dir = do
            contents <-
              ([FilePath] -> [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a] -> [a]
\\ [FilePath
".", FilePath
".."]) ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
getDirectoryContents (FilePath
baseDir FilePath -> FilePath -> FilePath
</> FilePath
dir)
            dirs <- catMaybes <$> mapM justDir contents
            files <- catMaybes <$> mapM justFile contents
            more <- concat <$> mapM (findAll . combine dir) dirs
            return $ (combine dir <$> files) ++ more
          where
            justFile :: FilePath -> IO (Maybe FilePath)
            justFile :: FilePath -> IO (Maybe FilePath)
justFile FilePath
filename = do
              isfile <-
                FileStatus -> Bool
isRegularFile (FileStatus -> Bool) -> IO FileStatus -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                  FilePath -> IO FileStatus
getFileStatus (FilePath
baseDir FilePath -> FilePath -> FilePath
</> FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
filename)
              return $ if isfile then Just filename else Nothing

            justDir :: FilePath -> IO (Maybe FilePath)
            justDir :: FilePath -> IO (Maybe FilePath)
justDir FilePath
filename = do
              isdir <-
                FileStatus -> Bool
isDirectory (FileStatus -> Bool) -> IO FileStatus -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                  FilePath -> IO FileStatus
getFileStatus (FilePath
baseDir FilePath -> FilePath -> FilePath
</> FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
filename)
              return $ if isdir then Just filename else Nothing
      in do
        allFiles <- FilePath -> IO [FilePath]
findAll FilePath
"."
        allContent
          <- mapM (fmap BS8.unpack . BS.readFile . combine baseDir) allFiles
        return (zip (drop 2 <$> allFiles) allContent)


{-| A WAI 'Application' that returns 404 not found for everything. -}
emptyApp :: Application
emptyApp :: Application
emptyApp Request
_req Response -> IO ResponseReceived
respond =
  Response -> IO ResponseReceived
respond
    (
      Status -> ResponseHeaders -> ByteString -> Response
responseLBS
        Status
status404
        ResponseHeaders
forall a. Monoid a => a
mempty
        ByteString
"not found"
    )


{- | Safely decode UTF-8 bytes to Text, replacing invalid sequences with placeholder. -}
decodeUtf8Safe :: ByteString -> Text
decodeUtf8Safe :: ByteString -> Text
decodeUtf8Safe ByteString
bytes =
  case ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
bytes of
    Left UnicodeException
_err -> Text
"<invalid utf8:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Base64 'StdPadded Text -> Text
forall (k :: Alphabet) a. Base64 k a -> a
extractBase64 (ByteString -> Base64 'StdPadded Text
encodeBase64 ByteString
bytes) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">"
    Right Text
val -> Text
val