{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
module Main where
import qualified Avahi
import qualified Data.Base16.Types as B16
import qualified Data.Binary.Builder as Binary.Builder
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Char8 as BS8
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map.Strict as Map
import qualified Data.Ron as Ron
import qualified Data.String
import qualified Data.Text as Text
import qualified Network.HTTP.Client as Client
import qualified Network.HTTP.Client.TLS as Client.Tls
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import qualified Portal
import qualified Static
import qualified System.Directory
import qualified System.Environment
import qualified System.Exit
import qualified System.FilePath
import qualified System.IO
import qualified Text.URI as Uri
import Control.Exception (handle)
import Control.Monad (forM_, when)
import Data.ByteString (ByteString)
import Data.Function (fix, (&))
import Data.HashMap.Strict (HashMap)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import GHC.Generics (Generic)
data IconType
= -- | Icon on the disk on this machine
LocalFile !Text
| -- | Remote icon which will be downloaded first
Url !Text
deriving (Eq, Show, Generic)
deriving
(Ron.FromRon)
via Ron.RonWith '[] IconType
data Service = Service
{ port :: !Int
-- ^ Port that the service is listening on
, title :: !(Maybe Text)
-- ^ Service title to show to user
, description :: !(Maybe Text)
-- ^ Optional descripction to show to user
, icon :: !(Maybe IconType)
-- ^ Optional service icon
}
deriving (Eq, Show, Generic)
deriving
(Ron.FromRon)
via Ron.RonWith
'[ Ron.EncodeWith Ron.SkipSingleConstructor
, Ron.DecodeWith Ron.ImplicitSome
]
Service
-- | Mapping of URLs to services. Services with these descriptions will be
-- created on these local domains
newtype ServicesConfig = ServicesConfig {getServicesConfig :: HashMap ByteString Service}
deriving (Eq, Show)
instance Ron.FromRon ServicesConfig where
fromRon = fmap (ServicesConfig . HashMap.fromList . Map.toList) . Ron.fromRon
data Settings = Settings
{ bindAddress :: !String
, bindPort :: !Int
, servicesPath :: !FilePath
, staticPath :: !FilePath
}
deriving (Eq, Show)
defaultSettings :: Settings
defaultSettings =
Settings
{ bindAddress = "*"
, bindPort = 80
, servicesPath = "/etc/dwierz/services.ron"
, staticPath = "/etc/dwierz/static"
}
-- Ignores incorrect arguments, doesn't give help
parseCommandLine :: [String] -> Settings -> Settings
parseCommandLine = go
where
go [] !x = x
go ("--bind" : host : rest) !x = go rest $! x{bindAddress = host}
go (('-' : '-' : 'b' : 'i' : 'n' : 'd' : '=' : host) : rest) !x = go rest $! x{bindAddress = host}
go ("--port" : port : rest) !x = go rest $! x{bindPort = read port}
go (('-' : '-' : 'p' : 'o' : 'r' : 't' : '=' : port) : rest) !x = go rest $! x{bindPort = read port}
go ("--services" : services : rest) !x = go rest $! x{servicesPath = services}
go (('-' : '-' : 's' : 'e' : 'r' : 'v' : 'i' : 'c' : 'e' : 's' : '=' : services) : rest) !x = go rest $! x{servicesPath = services}
go ("--static" : static : rest) !x = go rest $! x{staticPath = static}
go (('-' : '-' : 's' : 't' : 'a' : 't' : 'i' : 'c' : '=' : static) : rest) !x = go rest $! x{staticPath = static}
go (_noMatch : rest) !x = go rest x
commandLineHelp :: String
commandLineHelp =
unlines
[ "Usage: dwierz [ARGS]"
, ""
, "\t--bind - hostname to bind to in the weird warp format. '*' means any ipv4 or ipv6 host. Default: '*'"
, ""
, "\t--port - TCP port to bind to. Anything other than 80 will most likely give unexpected results. Default: 80"
, ""
, "\t--services - file with services configuration. Default: '/etc/dwierz/services.ron'"
, ""
, "\t--static - path to the static files root directory. Default: '/etc/dwierz/static'"
]
data App = App
{ servicesConfig :: !ServicesConfig
, httpManager :: !Client.Manager
, portalPage :: !ByteString
, staticRoot :: !FilePath
}
reverseProxyApp :: App -> Wai.Application
reverseProxyApp App{portalPage, staticRoot, httpManager, servicesConfig = ServicesConfig config} incomingRequest respond = do
let mbService = (HashMap.!?) config =<< Wai.requestHeaderHost incomingRequest
case mbService of
Just Service{port} -> proxyTo port httpManager incomingRequest respond
Nothing
| null $ Wai.pathInfo incomingRequest ->
respond $ Wai.responseLBS (toEnum 200) mempty $ BS.fromStrict portalPage
| otherwise -> Static.serveStatic staticRoot (Wai.pathInfo incomingRequest) respond
proxyTo :: Int -> Client.Manager -> Wai.Request -> (Wai.Response -> IO a) -> IO a
proxyTo targetPort manager incomingRequest respond = do
let streamsRequestBody = case Wai.requestBodyLength incomingRequest of
Wai.KnownLength len -> Client.RequestBodyStream $ fromIntegral len
Wai.ChunkedBody -> Client.RequestBodyStreamChunked
streamsRequestBody
:: ((Client.Popper -> IO ()) -> IO ()) -> Client.RequestBody
let requestBody =
streamsRequestBody $ \needsPopper ->
needsPopper $ Wai.getRequestBodyChunk incomingRequest
let request =
Client.defaultRequest
{ Client.method = Wai.requestMethod incomingRequest
, Client.secure = False
, Client.host = "localhost"
, Client.port = targetPort
, Client.path = Wai.rawPathInfo incomingRequest
, Client.queryString = Wai.rawQueryString incomingRequest
, Client.requestHeaders =
map (fixHost . fixReferer)
. filter (not . strippedHeader)
$ Wai.requestHeaders incomingRequest
, Client.requestBody = requestBody
, Client.proxy = Nothing
, Client.decompress = const False
, Client.redirectCount = 0
, Client.cookieJar = Nothing
, Client.requestVersion = Wai.httpVersion incomingRequest
}
Client.withResponse request manager $ \resp -> do
let status = Client.responseStatus resp
let headers = Client.responseHeaders resp
let nextBodyChunk = Client.responseBody resp
respond $ Wai.responseStream status headers $ \sendChunk flush ->
let sendChunk' = sendChunk . Binary.Builder.fromByteString
in resendFlushingBody nextBodyChunk sendChunk' flush
where
strippedHeader (k, v) =
k
`elem` [ "accept-encoding"
, "content-encoding"
, "content-length"
, "transfer-encoding"
]
|| k == "connection" && v == "close"
fixHost (k, v)
| k == "host" = (k, "localhost:" <> BS8.pack (show targetPort))
| otherwise = (k, v)
fixReferer (k, v)
| k == "referer" || k == "origin" = (k, changeUriHost (fromIntegral targetPort) v)
| otherwise = (k, v)
changeUriHost :: Word -> ByteString -> ByteString
changeUriHost port bs = case parseUri bs of
Left _e -> bs
Right uri ->
let auth = case Uri.uriAuthority uri of
Left b -> Left b
Right x ->
Right
x
{ Uri.authHost = localhost
, Uri.authPort = Just port
}
in renderUri uri{Uri.uriAuthority = auth}
where
parseUri = Uri.mkURIBs
localhost = case Uri.mkHost "localhost" of
Left e -> error $ "Error parsing localhost constant: " <> show e
Right x -> x
renderUri :: Uri.URI -> ByteString
renderUri = Uri.renderBs
resendFlushingBody :: IO ByteString -> (ByteString -> IO ()) -> IO () -> IO ()
resendFlushingBody getNext sendNext flush = go 0
where
go !len
| len >= 4096 = flush >> go 0
| otherwise = do
chunk <- getNext
if BS.length chunk == 0
then flush >> pure ()
else sendNext chunk >> go (len + BS.length chunk)
renderService :: (ByteString, Service) -> Portal.ServiceDefinition
renderService (domain, s) =
Portal.ServiceDefinition
{ Portal.url = url
, Portal.title = fromMaybe url (encodeUtf8 <$> title s)
, Portal.description = fromMaybe "" (encodeUtf8 <$> description s)
, Portal.icon = resolvedIcon
}
where
url = "http://" <> domain
resolvedIcon = flip fmap (icon s) $ \case
LocalFile x -> encodeUtf8 x
Url x -> encodeRemoteUrl x
encodeRemoteUrl :: Text -> ByteString
encodeRemoteUrl url =
"_downloaded/base16-"
<> (B16.extractBase16 . B16.encodeBase16' . encodeUtf8 $ url)
<> (BS8.pack . System.FilePath.takeExtension . Text.unpack $ url)
downloadFile :: Client.Manager -> Text -> FilePath -> IO ()
downloadFile manager url staticRoot = handle onHttpException $ do
let destPath = staticRoot <> "/" <> (Text.unpack . decodeUtf8 $ encodeRemoteUrl url)
request <- Client.parseRequest . Text.unpack $ url
Client.withResponse request manager $ \resp ->
if Client.responseStatus resp /= toEnum 200
then putStrLn $ "Non-ok response for " <> show url
else System.IO.withFile destPath System.IO.WriteMode $ \h ->
fix $ \again -> do
chunk <- Client.brRead . Client.responseBody $ resp
if BS.null chunk
then pure ()
else do
BS.hPut h chunk
again
where
onHttpException :: Client.HttpException -> IO ()
onHttpException e = putStrLn $ "Failed to download " <> show url <> "; reason: " <> show e
main :: IO ()
main = do
args <-
System.Environment.getArgs >>= \case
("--help" : _) ->
putStrLn commandLineHelp
>> System.Exit.exitWith System.Exit.ExitSuccess
x -> pure x
let appSettings@Settings{bindAddress, bindPort, servicesPath, staticPath} =
parseCommandLine args defaultSettings
putStrLn $ "App settings: " <> show appSettings
servicesConfig <- Ron.decodeFile servicesPath
putStrLn $ "Read services: " <> show servicesConfig
let portalServices = map renderService . HashMap.toList . getServicesConfig $ servicesConfig
let portalPage = Portal.makePortal portalServices
-- create mdns domains
avahiClient <- Avahi.createClient
myHostname <- Avahi.getHostName avahiClient
forM_ (HashMap.keys . getServicesConfig $ servicesConfig) $ \serviceHost -> do
let host = decodeUtf8 serviceHost
entryGroup <- Avahi.entryGroupNew avahiClient
Avahi.entryGroupAddRecord avahiClient entryGroup host myHostname
Avahi.entryGroupCommit avahiClient entryGroup
putStrLn $ "Created record for " <> show host
httpManager <- Client.Tls.newTlsManager
-- download all remote icons
System.Directory.createDirectoryIfMissing True $ staticPath <> "/_downloaded"
let icons =
catMaybes
. map (\case Url x -> Just x; _ -> Nothing)
. catMaybes
. map icon
. HashMap.elems
. getServicesConfig
$ servicesConfig
forM_ icons $ \iconUrl -> do
let path = staticPath <> "/" <> (Text.unpack . decodeUtf8 $ encodeRemoteUrl iconUrl)
exists <- System.Directory.doesFileExist path
when (not exists) $ do
putStrLn $ "Downloading " <> show iconUrl
downloadFile httpManager iconUrl staticPath
putStrLn "Starting HTTP server"
let app =
reverseProxyApp
App
{ servicesConfig
, httpManager
, portalPage
, staticRoot = staticPath
}
let warpSettings =
Warp.defaultSettings
& Warp.setPort bindPort
& Warp.setHost (Data.String.fromString bindAddress)
Warp.runSettings warpSettings app
Avahi.dropClient avahiClient