renamed project to gemcap

It was brought to my attention that there is a rust package named gemserv. I changed the name to avoid any potential confusion.

src/Network/Gemini/Capsule.hs

@@ -0,0 +1,228 @@
+{-|
+
+Module      : Network.Gemini.Capsule
+Description : Gemini capsule 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.Gemini.Capsule (
+  -- * 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, finally)
+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 qualified Data.Connection as C
+import Data.IORef (IORef, newIORef, readIORef, 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 qualified Network.Socket as S
+import Network.TLS (ServerParams, onClientCertificate, serverHooks)
+import System.IO.Streams.TCP (bindAndListen)
+import System.IO.Streams.TLS (accept)
+
+import Network.Gemini.Capsule.Internal
+import Network.Gemini.Capsule.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)
+  )
+  S.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 :: S.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 $ finally
+      (readIORef certRef >>= runConnection conn handler)
+      (C.close conn)
+  listenLoop sock params handler
+
+adjustServerParams
+  :: IORef (Maybe Certificate)
+  -> ServerParams
+  -> ServerParams
+adjustServerParams certRef params = let
+  hooks    = serverHooks params
+  certHook = onClientCertificate hooks
+
+  certHook' chain = do
+    case chain of
+      CertificateChain []     -> return ()
+      CertificateChain (se:_) -> do
+        let cert = signedObject $ getSigned se
+        writeIORef certRef (Just cert)
+    certHook chain
+
+  hooks' = hooks { onClientCertificate = certHook' }
+  in params { serverHooks = hooks' }
+
+runConnection
+  :: C.Connection a
+  -> GemHandler
+  -> Maybe Certificate
+  -> IO ()
+runConnection conn handler mCert =
+  ( readURL conn >>= \case
+    Nothing -> return $ newGemResponse
+      { respStatus = 59
+      , respMeta   = "bad request"
+      }
+    Just url -> handler (newGemRequest url) { reqCert = mCert }
+  ) >>= sendResponse conn
+
+hexDigits :: String
+hexDigits = ['0'..'9'] ++ ['a'..'f']
+
+--jl

src/Network/Gemini/Capsule/Internal.hs

@@ -0,0 +1,58 @@
+{-|
+
+Module      : Network.Gemini.Capsule.Internal
+Description : internal functions (do not use)
+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/>.
+
+= Important Note
+
+This is an internal module.  It is not intended to be accessed by
+outside packages, and should be considered subject to change at any
+time.
+
+-}
+
+module Network.Gemini.Capsule.Internal (
+  readURL,
+  sendResponse
+) where
+
+import Data.Connection (Connection)
+
+import Network.Gemini.Capsule.Types
+
+-- | Reads a 'GemURL' from a 'Connection'
+readURL
+  :: Connection a
+  -- ^ the connection
+  -> IO (Maybe GemURL)
+readURL = undefined
+
+-- | Sends a 'GemResponse' to a 'Connection'
+sendResponse
+  :: Connection a
+  -- ^ the connection
+  -> GemResponse
+  -- ^ the response being sent
+  -> IO ()
+sendResponse = undefined
+
+--jl

src/Network/Gemini/Capsule/Types.hs

@@ -0,0 +1,137 @@
+{-|
+
+Module      : Network.Gemini.Capsule.Types
+Description : Gemini capsule types
+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/>.
+
+-}
+
+module Network.Gemini.Capsule.Types (
+  -- * Types
+  GemURL (..),
+  GemRequest (..),
+  GemResponse (..),
+  GemHandler,
+  GemServSettings (..),
+  -- * Constructors
+  newGemURL,
+  newGemRequest,
+  newGemResponse,
+  newGemServSettings
+) where
+
+import qualified Data.ByteString.Lazy as BSL
+import Data.Word (Word8, Word16, Word32)
+import Data.X509 (Certificate)
+
+-- | Gemini URL
+data GemURL = GemURL
+  { gemHost :: String
+  -- ^ The host part of the authority section, e.g.: "example.com"
+  , gemPort :: Maybe Word32
+  -- ^ The port number (if supplied)
+  , gemPath :: [String]
+  -- ^ The decoded path segments
+  , gemQuery :: Maybe String
+  -- ^ The decoded request query (if supplied)
+  } deriving (Eq, Show)
+
+-- | Describes a Gemini request
+data GemRequest = GemRequest
+  { reqURL :: GemURL
+  -- ^ The URL being requested
+  , reqCert :: Maybe Certificate
+  -- ^ The client certificate (if available)
+  } deriving (Eq, Show)
+
+-- | Describes a response to a Gemini request
+data GemResponse = GemResponse
+  { respStatus :: Word8
+  -- ^ The response status code
+  , respMeta :: String
+  -- ^ The response metadata
+  , respBody :: Maybe BSL.ByteString
+  -- ^ The response body
+  } deriving (Eq, Show)
+
+-- | Handles a 'GemRequest' to produce a 'GemResponse'
+type GemHandler = GemRequest -> IO GemResponse
+
+-- | The settings required to set up a Gemini server
+data GemServSettings = GemServSettings
+  { servConnections :: Int
+  -- ^ Number of simultaneous connections allowed
+  , servPort :: Word16
+  -- ^ The server port number
+  , servCert :: FilePath
+  -- ^ The path to the server certificate
+  , servCertChain :: [FilePath]
+  -- ^ The paths to the chain certificates
+  , servKey :: FilePath
+  -- ^ The path to the private key
+  } deriving (Eq, Show)
+
+-- | Builds a new 'GemURL'
+newGemURL
+  :: String
+  -- ^ The hostname
+  -> GemURL
+newGemURL host = GemURL
+  { gemHost  = host
+  , gemPort  = Nothing
+  , gemPath  = []
+  , gemQuery = Nothing
+  }
+
+-- | Builds a 'GemRequest'
+newGemRequest
+  :: GemURL
+  -- ^ The request URL
+  -> GemRequest
+newGemRequest url = GemRequest
+  { reqURL  = url
+  , reqCert = Nothing
+  }
+
+-- | Builds a 'GemResponse'
+newGemResponse :: GemResponse
+newGemResponse = GemResponse
+  { respStatus = 20
+  , respMeta   = "text/gemini"
+  , respBody   = Nothing
+  }
+
+-- | Builds a reasonable set of server settings.
+newGemServSettings
+  :: FilePath
+  -- ^ Path to the server certificate
+  -> FilePath
+  -- ^ Path to the private key
+  -> GemServSettings
+newGemServSettings cert key = GemServSettings
+  { servConnections = 100
+  , servPort        = 1965
+  , servCert        = cert
+  , servCertChain   = []
+  , servKey         = key
+  }
+
+--jl