{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module OM.HTTP (
runTlsRedirect,
hstsDirective,
requestLogging,
setServer,
insertResponseHeaderIfMissing,
overwriteResponseHeader,
staticSite,
logExceptionsAndContinue,
sshConnect,
staticPage,
defaultIndex,
BearerToken(..),
) where
import Prelude (Either(Left, Right), Eq((/=), (==)), Foldable(elem,
foldr), Functor(fmap), Maybe(Just, Nothing), Monad((>>), (>>=), return),
MonadFail(fail), RealFrac(truncate), Semigroup((<>)), Show(show),
Traversable(mapM), ($), (++), (.), (<$>), (=<<), FilePath, IO, Int,
String, concat, drop, filter, fst, id, mapM_, otherwise, putStrLn, zip)
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (concurrently_)
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 (Loc, LogLevel, LogSource, LogStr,
MonadLoggerIO, logError, logInfo, runLoggingT)
import Data.ByteString (ByteString)
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 (Header, Status, internalServerError500,
methodNotAllowed405, movedPermanently301, ok200, statusCode,
statusMessage)
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 (Application, Middleware, Response, ResponseReceived,
mapResponseHeaders, pathInfo, rawPathInfo, rawQueryString,
requestMethod, responseLBS, responseRaw, responseStatus)
import Network.Wai.Handler.Warp (run)
import OM.Show (showt)
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.Text as T
runTlsRedirect
:: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> ByteString
-> Version
-> ByteString
-> IO ()
runTlsRedirect :: (Loc -> FileName -> LogLevel -> LogStr -> IO ())
-> ByteString -> Version -> ByteString -> IO ()
runTlsRedirect Loc -> FileName -> 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 -> FileName -> LogLevel -> LogStr -> IO ())
-> Application -> Application
requestLogging Loc -> FileName -> 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 -> FileName -> LogLevel -> LogStr -> IO ())
-> Application -> Application
logExceptionsAndContinue Loc -> FileName -> LogLevel -> LogStr -> IO ()
logging
(Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Application
tlsRedirect ByteString
url
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))
insertResponseHeaderIfMissing :: Header -> Middleware
(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
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>"
)
setServer :: ByteString -> Version -> Middleware
setServer :: ByteString -> Version -> Application -> Application
setServer ByteString
serviceName Version
version =
Header -> Application -> Application
overwriteResponseHeader (HeaderName
"Server", ByteString
serverValue)
where
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)
overwriteResponseHeader :: Header -> Middleware
(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
requestLogging
:: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> Middleware
requestLogging :: (Loc -> FileName -> LogLevel -> LogStr -> IO ())
-> Application -> Application
requestLogging Loc -> FileName -> LogLevel -> LogStr -> IO ()
logging Application
app Request
req Response -> IO ResponseReceived
respond =
(LoggingT IO ResponseReceived
-> (Loc -> FileName -> LogLevel -> LogStr -> IO ())
-> IO ResponseReceived
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> FileName -> LogLevel -> LogStr -> IO ()) -> m a
`runLoggingT` Loc -> FileName -> LogLevel -> LogStr -> IO ()
logging) (LoggingT IO ResponseReceived -> IO ResponseReceived)
-> LoggingT IO ResponseReceived -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ do
$(logInfo) (FileName -> LoggingT IO ()) -> FileName -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ FileName
"Starting request: " FileName -> FileName -> FileName
forall a. Semigroup a => a -> a -> a
<> FileName
reqStr
IO ResponseReceived -> LoggingT IO ResponseReceived
forall a. IO a -> LoggingT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> LoggingT IO ResponseReceived)
-> (UTCTime -> IO ResponseReceived)
-> UTCTime
-> LoggingT IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Application
app Request
req ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (UTCTime -> Response -> IO ResponseReceived)
-> UTCTime
-> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Response -> IO ResponseReceived
loggingRespond (UTCTime -> LoggingT IO ResponseReceived)
-> LoggingT IO UTCTime -> LoggingT IO ResponseReceived
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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
where
loggingRespond :: UTCTime -> Response -> IO ResponseReceived
loggingRespond :: UTCTime -> Response -> IO ResponseReceived
loggingRespond UTCTime
start Response
response = (LoggingT IO ResponseReceived
-> (Loc -> FileName -> LogLevel -> LogStr -> IO ())
-> IO ResponseReceived
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> FileName -> LogLevel -> LogStr -> IO ()) -> m a
`runLoggingT` Loc -> FileName -> LogLevel -> LogStr -> IO ()
logging) (LoggingT IO ResponseReceived -> IO ResponseReceived)
-> LoggingT IO ResponseReceived -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ do
ResponseReceived
ack <- IO ResponseReceived -> LoggingT IO ResponseReceived
forall a. IO a -> LoggingT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> LoggingT IO ResponseReceived)
-> IO ResponseReceived -> LoggingT IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Response -> IO ResponseReceived
respond Response
response
UTCTime
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
$(logInfo)
(FileName -> LoggingT IO ()) -> FileName -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ FileName
reqStr FileName -> FileName -> FileName
forall a. Semigroup a => a -> a -> a
<> FileName
" --> " FileName -> FileName -> FileName
forall a. Semigroup a => a -> a -> a
<> Status -> FileName
showStatus (Response -> Status
responseStatus Response
response)
FileName -> FileName -> FileName
forall a. Semigroup a => a -> a -> a
<> FileName
" (" FileName -> FileName -> FileName
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> FileName
forall a b. (Show a, IsString b) => a -> b
showt (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now UTCTime
start) FileName -> FileName -> FileName
forall a. Semigroup a => a -> a -> a
<> FileName
")"
ResponseReceived -> LoggingT IO ResponseReceived
forall a. a -> LoggingT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
ack
reqStr :: Text
reqStr :: FileName
reqStr = ByteString -> FileName
decodeUtf8
(ByteString -> FileName) -> ByteString -> FileName
forall a b. (a -> b) -> a -> b
$ 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
showStatus :: Status -> Text
showStatus :: Status -> FileName
showStatus Status
stat =
(Int -> FileName
forall a b. (Show a, IsString b) => a -> b
showt (Int -> FileName) -> (Status -> Int) -> Status -> FileName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> Int
statusCode) Status
stat FileName -> FileName -> FileName
forall a. Semigroup a => a -> a -> a
<> FileName
" " FileName -> FileName -> FileName
forall a. Semigroup a => a -> a -> a
<> (ByteString -> FileName
decodeUtf8 (ByteString -> FileName)
-> (Status -> ByteString) -> Status -> FileName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> ByteString
statusMessage) Status
stat
logExceptionsAndContinue
:: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> Middleware
logExceptionsAndContinue :: (Loc -> FileName -> LogLevel -> LogStr -> IO ())
-> Application -> Application
logExceptionsAndContinue Loc -> FileName -> LogLevel -> LogStr -> IO ()
logging Application
app Request
req Response -> IO ResponseReceived
respond = (LoggingT IO ResponseReceived
-> (Loc -> FileName -> LogLevel -> LogStr -> IO ())
-> IO ResponseReceived
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> FileName -> LogLevel -> LogStr -> IO ()) -> m a
`runLoggingT` Loc -> FileName -> 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
uuid <- SomeException -> LoggingT IO UUID
forall (m :: * -> *). MonadLoggerIO m => SomeException -> m UUID
logProblem SomeException
err
IO ResponseReceived -> LoggingT IO ResponseReceived
forall a. IO a -> LoggingT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> LoggingT IO ResponseReceived)
-> IO ResponseReceived -> LoggingT IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Response -> IO ResponseReceived
respond (UUID -> Response
errResponse UUID
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 -> FileName -> LogLevel -> LogStr -> IO ())
-> IO ResponseReceived
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> FileName -> LogLevel -> LogStr -> IO ()) -> m a
`runLoggingT` Loc -> FileName -> 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
uuid <- m UUID
forall (m :: * -> *). MonadIO m => m UUID
getUUID
$(logError)
(FileName -> m ()) -> FileName -> m ()
forall a b. (a -> b) -> a -> b
$ FileName
"Internal Server Error [" FileName -> FileName -> FileName
forall a. Semigroup a => a -> a -> a
<> UUID -> FileName
forall a b. (Show a, IsString b) => a -> b
showt UUID
uuid FileName -> FileName -> FileName
forall a. Semigroup a => a -> a -> a
<> FileName
"]: "
FileName -> FileName -> FileName
forall a. Semigroup a => a -> a -> a
<> SomeException -> FileName
forall a b. (Show a, IsString b) => a -> b
showt SomeException
err
UUID -> m UUID
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return UUID
uuid
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
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]
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)
)
pipeInbound :: Socket -> IO ByteString -> IO ()
pipeInbound :: Socket -> IO ByteString -> IO ()
pipeInbound Socket
so IO ByteString
read_ = do
ByteString
bytes <- IO ByteString
read_
if ByteString -> Bool
BS.null ByteString
bytes
then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do
Socket -> ByteString -> IO ()
sendAll Socket
so ByteString
bytes
Socket -> IO ByteString -> IO ()
pipeInbound Socket
so IO ByteString
read_
pipeOutbound :: Socket -> (ByteString -> IO ()) -> IO ()
pipeOutbound :: Socket -> (ByteString -> IO ()) -> IO ()
pipeOutbound Socket
so ByteString -> IO ()
write = do
ByteString
bytes <- Socket -> Int -> IO ByteString
recv Socket
so Int
4096
ByteString -> IO ()
write ByteString
bytes
if ByteString -> Bool
BS.null ByteString
bytes
then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else Socket -> (ByteString -> IO ()) -> IO ()
pipeOutbound Socket
so ByteString -> IO ()
write
staticPage
:: [Text]
-> ByteString
-> BSL.ByteString
-> Middleware
staticPage :: [FileName]
-> ByteString -> ByteString -> Application -> Application
staticPage [FileName]
path ByteString
ct ByteString
bytes Application
app Request
req Response -> IO ResponseReceived
respond =
if Request -> [FileName]
pathInfo Request
req [FileName] -> [FileName] -> Bool
forall a. Eq a => a -> a -> Bool
== [FileName]
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
defaultIndex :: Middleware
defaultIndex :: Application -> Application
defaultIndex Application
app Request
request Response -> IO ResponseReceived
respond =
case Request -> [FileName]
pathInfo Request
request of
[] -> Application
app Request
request {pathInfo = ["index.html"]} Response -> IO ResponseReceived
respond
[FileName]
_ -> Application
app Request
request Response -> IO ResponseReceived
respond
newtype BearerToken = BearerToken {
BearerToken -> FileName
unBearerToken :: Text
}
instance ToHttpApiData BearerToken where
toUrlPiece :: BearerToken -> FileName
toUrlPiece BearerToken
t = FileName
"Bearer " FileName -> FileName -> FileName
forall a. Semigroup a => a -> a -> a
<> BearerToken -> FileName
unBearerToken BearerToken
t
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
[(FilePath, FilePath)]
files <- IO [(FilePath, FilePath)]
readStaticFiles
((FilePath, FilePath) -> IO ()) -> [(FilePath, FilePath)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FilePath -> IO ()
printResource (FilePath -> IO ())
-> ((FilePath, FilePath) -> FilePath)
-> (FilePath, FilePath)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst) [(FilePath, FilePath)]
files
Q (TExp (Application -> Application))
-> IO (Q (TExp (Application -> Application)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Q (TExp (Application -> Application))
-> IO (Q (TExp (Application -> Application))))
-> Q (TExp (Application -> Application))
-> IO (Q (TExp (Application -> Application)))
forall a b. (a -> b) -> a -> b
$ ((FilePath, FilePath) -> Q ()) -> [(FilePath, FilePath)] -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FilePath -> Q ()
addDependentFile (FilePath -> Q ())
-> ((FilePath, FilePath) -> FilePath)
-> (FilePath, FilePath)
-> Q ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath
baseDir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/") FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) (FilePath -> FilePath)
-> ((FilePath, FilePath) -> FilePath)
-> (FilePath, FilePath)
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst) [(FilePath, FilePath)]
files Q ()
-> Q (TExp (Application -> Application))
-> Q (TExp (Application -> Application))
forall a b. Q a -> Q b -> Q b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Code Q (Application -> Application)
-> Q (TExp (Application -> Application))
forall (m :: * -> *) a. Code m a -> m (TExp a)
examineCode [||
let
static :: (FilePath, String) -> Middleware
static :: (FilePath, FilePath) -> Application -> Application
static (FilePath
filename, FilePath
content) Application
app Request
req Response -> IO ResponseReceived
respond =
let
ct :: ByteString
ct :: ByteString
ct =
FileName -> 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 -> [FileName]
pathInfo Request
req a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== (Char -> Bool) -> FileName -> [FileName]
T.split (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (FilePath -> FileName
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
(a -> b -> b) -> b -> t a -> b
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (b -> c) -> (a -> b) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) a -> a
forall a. a -> a
id ((a -> b) -> f a -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath, FilePath) -> Application -> Application
static a
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)
readStaticFiles :: IO [(FilePath, String)]
readStaticFiles :: IO [(FilePath, FilePath)]
readStaticFiles =
let
findAll :: FilePath -> IO [FilePath]
findAll :: FilePath -> IO [FilePath]
findAll FilePath
dir = do
[FilePath]
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)
[FilePath]
dirs <- [Maybe FilePath] -> [FilePath]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe FilePath] -> [FilePath])
-> IO [Maybe FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO (Maybe FilePath))
-> [FilePath] -> IO [Maybe FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM FilePath -> IO (Maybe FilePath)
justDir [FilePath]
contents
[FilePath]
files <- [Maybe FilePath] -> [FilePath]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe FilePath] -> [FilePath])
-> IO [Maybe FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO (Maybe FilePath))
-> [FilePath] -> IO [Maybe FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM FilePath -> IO (Maybe FilePath)
justFile [FilePath]
contents
[FilePath]
more <- [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FilePath]] -> [FilePath]) -> IO [[FilePath]] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (FilePath -> IO [FilePath]
findAll (FilePath -> IO [FilePath])
-> (FilePath -> FilePath) -> FilePath -> IO [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
combine FilePath
dir) [FilePath]
dirs
[FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath -> FilePath
combine FilePath
dir (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
files) [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
more
where
justFile :: FilePath -> IO (Maybe FilePath)
justFile :: FilePath -> IO (Maybe FilePath)
justFile FilePath
filename = do
Bool
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)
Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ if Bool
isfile then FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
filename else Maybe FilePath
forall a. Maybe a
Nothing
justDir :: FilePath -> IO (Maybe FilePath)
justDir :: FilePath -> IO (Maybe FilePath)
justDir FilePath
filename = do
Bool
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)
Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ if Bool
isdir then FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
filename else Maybe FilePath
forall a. Maybe a
Nothing
in do
[FilePath]
allFiles <- FilePath -> IO [FilePath]
findAll FilePath
"."
[FilePath]
allContent
<- (FilePath -> IO FilePath) -> [FilePath] -> IO [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((ByteString -> FilePath) -> IO ByteString -> IO FilePath
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> FilePath
BS8.unpack (IO ByteString -> IO FilePath)
-> (FilePath -> IO ByteString) -> FilePath -> IO FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ByteString
BS.readFile (FilePath -> IO ByteString)
-> (FilePath -> FilePath) -> FilePath -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
combine FilePath
baseDir) [FilePath]
allFiles
[(FilePath, FilePath)] -> IO [(FilePath, FilePath)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> [FilePath] -> [(FilePath, FilePath)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
2 (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
allFiles) [FilePath]
allContent)