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, RecordWildCards #-}

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

import Control.Exception.Base (bracket)
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.List (find, intercalate)
import Data.Maybe (fromJust)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8')
import Network.Socket (close)
import System.IO.Streams.TCP (bindAndListen)

import Network.GemServ.Types

-- | Builds and runs a Gemini server
runGemServer
  :: GemServSettings
  -- ^ The server settings
  -> GemHandler
  -- ^ The handler
  -> IO ()
runGemServer settings _ = bracket
  ( bindAndListen
    (servConnections settings)
    (fromIntegral $ servPort settings)
  )
  close
  undefined

-- | 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

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

--jl