gemcap/src/Network/GemServ.hs

{-|

Module      : Network.GemServ
Description : Gemini Server Stuff
Copyright   : (C) Jonathan Lamothe
License     : AGPL-3.0-or-later
Maintainer  : jonathan@jlamothe.net
Stability   : experimental
Portability : POSIX

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Affero General Public License as
published by the Free Software Foundation, either version 3 of the
License, or (at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Affero General Public License for more details.

You should have received a copy of the GNU Affero General Public
License along with this program.  If not, see
<https://www.gnu.org/licenses/>.

-}

{-# LANGUAGE
    LambdaCase,
    OverloadedStrings,
    ScopedTypeVariables,
    RecordWildCards #-}

module Network.GemServ (
  -- * Running a Gemini Server
  runGemServer,
  -- * Encoding/Decoding Functions
  encodeGemURL,
  decodeGemURL,
  escapeString,
  unescapeString
) where

import Control.Concurrent (forkIO)
import Control.Exception (IOException, try)
import Control.Exception.Base (bracket)
import Control.Monad (void)
import qualified Data.ByteString as BS
import Data.ByteString.Builder (charUtf8, stringUtf8, toLazyByteString)
import qualified Data.ByteString.Lazy as BSL
import Data.Char (chr, ord, toLower)
import Data.IORef (IORef, newIORef, writeIORef)
import Data.List (find, intercalate)
import Data.Maybe (fromJust)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8')
import Data.TLSSetting (makeServerParams)
import Data.X509 (Certificate, CertificateChain (..), getSigned, signedObject)
import Network.Socket (Socket, close)
import Network.TLS (ServerParams, onClientCertificate, serverHooks)
import System.IO.Streams.TCP (bindAndListen)
import System.IO.Streams.TLS (accept)

import Network.GemServ.Internal
import Network.GemServ.Types

-- | Builds and runs a Gemini server
runGemServer
  :: GemServSettings
  -- ^ The server settings
  -> GemHandler
  -- ^ The handler
  -> IO a
runGemServer settings handler = bracket
  ( bindAndListen
    (servConnections settings)
    (fromIntegral $ servPort settings)
  )
  close
  ( \sock -> do
    params <- makeServerParams
      (servCert settings)
      (servCertChain settings)
      (servKey settings)
    listenLoop sock params handler
  )

-- | Encodes a 'GemURL' into a 'String'
encodeGemURL :: GemURL -> String
encodeGemURL url =
  "gemini://" ++ authority ++ "/" ++ path ++ query
  where
    authority = gemHost url ++ case gemPort url of
      Just port -> ':' : show port
      Nothing   -> ""
    path = intercalate "/" $ map escapeString $ gemPath url
    query = case gemQuery url of
      Nothing -> ""
      Just q  -> '?' : escapeString q

-- | Decodes a 'GemURL' from a 'String' (if possible)
decodeGemURL :: String -> Maybe GemURL
decodeGemURL str = do
  let txt = T.pack str

  noProt <- case T.splitOn "://" txt of
    [prot, rest] -> if T.toLower prot == "gemini"
      then Just rest
      else Nothing
    _ -> Nothing

  noFrag <- case T.splitOn "#" noProt of
    [x, _] -> Just x
    [x]    -> Just x
    _      -> Nothing

  (noQuery, query) <- case T.splitOn "?" noFrag of
    [nq, q] -> Just (nq, Just q)
    [nq]    -> Just (nq, Nothing)
    _       -> Nothing

  gemQuery <- case query of
    Just q  -> Just <$> unescapeString (T.unpack q)
    Nothing -> Just Nothing

  (auth, path) <- case T.splitOn "/" noQuery of
    [a]     -> Just (a, [])
    [a, ""] -> Just (a, [])
    a:ps    -> Just (a, ps)
    _       -> Nothing

  gemPath  <- mapM (unescapeString . T.unpack) path

  (host, gemPort) <- case T.splitOn ":" auth of
    [h, p] -> case reads $ T.unpack p of
      [(n, "")] -> Just (h, Just n)
      _         -> Nothing
    [h] -> Just (h, Nothing)
    _   -> Nothing

  let gemHost = T.unpack host
  Just GemURL {..}

-- | add required escape sequences to a string
escapeString :: String -> String
escapeString = concatMap
  ( \n -> let ch = chr $ fromIntegral n in
    if ch `elem` unescaped
    then [ch]
    else '%' : toHex n
  ) . BSL.unpack . toLazyByteString . stringUtf8
  where
    unescaped = ['0'..'9'] ++ ['A'..'Z'] ++ ['a'..'z'] ++ "~-_."
    toHex =
      ( \n -> let
        high = n `div` 16
        low  = n `mod` 16
        in [hexDigits !! high, hexDigits !! low]
      ) . fromIntegral

-- | decode an escaped string back to its original value
unescapeString :: String -> Maybe String
unescapeString str = case decodeUtf8' $ BS.pack $ toBytes str of
    Right t -> Just $ T.unpack t
    _       -> Nothing
  where
    toBytes = \case
      "" -> []
      '%':h:l:sub -> let
        h' = toLower h
        l' = toLower l
        in if h' `elem` hexDigits && l' `elem` hexDigits
        then toByte h' l' : toBytes sub
        else fromIntegral (ord '%') : toBytes (h : l : sub)
      ch:sub ->
        BSL.unpack (toLazyByteString $ charUtf8 ch) ++ toBytes sub
    toByte h l = toNum h * 16 + toNum l
    toNum ch = fst $ fromJust $
      find (\x -> snd x == ch) $ zip [0..] hexDigits

listenLoop :: Socket -> ServerParams -> GemHandler -> IO a
listenLoop sock params handler = do
  certRef <- newIORef Nothing
  let params' = adjustServerParams certRef params
  try (accept params' sock) >>= \case
    Left (_ :: IOException) -> return ()
    Right conn              -> void $ forkIO $ runConnection conn handler
  listenLoop sock params handler

adjustServerParams
  :: IORef (Maybe Certificate)
  -> ServerParams
  -> ServerParams
adjustServerParams certRef params = let
  hooks    = serverHooks params
  certHook = onClientCertificate hooks

  certHook' chain = case chain of
    CertificateChain []     -> certHook chain
    CertificateChain (se:_) -> do
      let cert = signedObject $ getSigned se
      writeIORef certRef (Just cert)
      certHook chain

  hooks' = hooks { onClientCertificate = certHook' }
  in params { serverHooks = hooks' }

hexDigits :: String
hexDigits = ['0'..'9'] ++ ['a'..'f']

--jl