Initial commit

This is a working version that can serve pages, yay! A lot of features
still missing though, as well as proper package metadata.

6 files changed, 556 insertions, 0 deletions

diff --git a/src/Cana.hs b/src/Cana.hs
new file mode 100644
index 0000000..5822ccb
--- /dev/null
+++ b/src/Cana.hs
@@ -0,0 +1,196 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- |
+-- Module  : Cana
+-- License : BSD3
+--
+-- "Cana" is a library implementing a [Project
+-- Gemini](https://gemini.circumlunar.space/docs/specification.html) server.
+-- The main goal of "Cana" is to provide a simple way for other applications to
+-- run a Gemini server, as it can be as simple as a few lines of code:
+--
+-- > {-# LANGUAGE OverloadedStrings #-}
+-- > module Main where
+-- >
+-- > import Cana
+-- > import Cana.Protocol
+-- > import Cana.Router
+-- >
+-- > defaultResponse :: GeminiResponse
+-- > defaultResponse = GeminiResponse
+-- >   { responseStatus = codeSuccess
+-- >   , responseMeta   = "text/gemini"
+-- >   , responseData   = "# Hello World\nThis page was served by Cana."
+-- >   }
+-- >
+-- > main :: IO ()
+-- > main = runGeminiServer Nothing defaultGeminiPort "certificate.crt" "private.key"
+-- >   [ (anyRoute, const $ return defaultResponse)
+-- >   ]
+--
+-- Note that the module is split in a few different submodules:
+--
+-- * "Cana.Server" contains the server settings setup function.
+-- * "Cana.Monad" contains function for working with the 'Cana' monad.
+-- * "Cana.Types" defines all necessary types.
+-- * "Cana.Protocol" contains low-level protocol definitions from the
+--   specification, such as a variety of status codes.
+-- * "Cana.Router" defines functions for defining 'Route's.
+
+module Cana
+    ( -- * High-Level API
+      runGeminiServer
+      -- * Low-Level API
+    , loadCredentials
+    , canaServer
+    , canaClient
+    , writeResponse
+    ) where
+
+import Cana.Server
+import Cana.Monad
+import Cana.Types
+import Cana.Protocol
+import Cana.Router
+
+import Data.List
+import Control.Monad.IO.Class
+import Control.Concurrent (forkFinally)
+import qualified Control.Exception as E
+import Control.Monad (unless, forever, void)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BSL
+import qualified Data.ByteString.Char8 as C
+import Network.Socket
+import Network.URI
+
+import qualified Network.TLS as TLS
+
+-- | Run the Gemini server.
+--
+-- This is your one-stop-shop to quickly get a Gemini server running.
+--
+-- If you need finer grained control, check the other functions defined in this
+-- module.
+runGeminiServer :: Maybe HostName -- ^ Hostname to bind to.
+                -> ServiceName    -- ^ Service name to listen on.
+                -> FilePath       -- ^ Certificate key file.
+                -> FilePath       -- ^ Private key file.
+                -> [Route]        -- ^ Server routes.
+                -> IO ()
+runGeminiServer hostName serviceName credFile keyFile routes = do
+  creds <- loadCredentials credFile keyFile
+  result <- runCana (mkGeminiServer hostName serviceName creds routes) canaServer
+  case result of
+    Right _ -> return ()
+    Left  s -> fail s
+
+-- | Load the credentials.
+--
+-- This uses 'fail' if the loading of the credentials fails.
+loadCredentials :: FilePath -- ^ Certificate file path.
+                -> FilePath -- ^ Private key file path.
+                -> IO TLS.Credentials -- ^ The loaded credentials.
+loadCredentials certFile keyFile = do
+  creds <- TLS.credentialLoadX509 "certificate.crt" "private.key" >>= unwrap
+  return $ TLS.Credentials [creds]
+    where
+      unwrap :: Either String a -> IO a
+      unwrap (Left s) = fail s
+      unwrap (Right x) = pure x
+
+-- | Run the actual Gemini server.
+--
+-- Note that the server parameters are available through the 'Cana' monad, so
+-- you have to use 'runCana' in combination with 'mkGeminiServer' to set up the
+-- correct parameters.
+canaServer :: Cana ()
+canaServer = do
+  server <- askGeminiServer
+  liftIO $ runTCPServer (serverHostName server) (serverPort server) (handleClient server)
+    where
+      handleClient server connection = do
+        result <- runCana server (canaClient connection)
+        case result of
+          Right _ -> pure ()
+          Left s  -> logError s
+
+-- | Handler function for a single Gemini client.
+--
+-- This function sets up the TLS context, reads the request and computes the
+-- reply. This function should be called with 'forkFinally' to not block other
+-- clients.
+--
+-- If you have a listening socket already set up, this is the function that you
+-- want to use in order to handle a single Gemini client connection.
+canaClient :: Socket -> Cana ()
+canaClient socket = do
+  params <- asks serverParams
+  -- Set up TLS context
+  context <- TLS.contextNew socket params
+  TLS.handshake context
+  -- Parse request
+  clientCert <- liftIO $ TLS.getClientCertificateChain context
+  request <- BS.takeWhile (\c -> c /= 10 && c /= 13) <$> TLS.recvData context
+  uri <- case parseURI $ C.unpack request of
+           Just u  -> pure u
+           Nothing -> do
+             writeResponse context $ GeminiResponse
+               { responseStatus = codeBadRequest
+               , responseMeta   = BSL.empty
+               , responseData   = BSL.empty
+               }
+             throw "Malformed client request"
+  -- Acquire resource
+  logInfo ("Request: " ++ show uri)
+  let geminiRequest = GeminiRequest {
+        requestUri  = uri
+      , requestCert = clientCert
+      }
+  route <- findRoute geminiRequest
+  case route of
+    Just r  -> do
+      response <- r geminiRequest
+      writeResponse context response
+    Nothing -> do
+      writeResponse context $ GeminiResponse
+        { responseStatus = codeNotFound
+        , responseMeta   = ""
+        , responseData   = ""
+        }
+
+-- | Render a response and write it to the TLS encrypted socket.
+writeResponse :: TLS.Context -> GeminiResponse -> Cana ()
+writeResponse context = TLS.sendData context . renderResponse
+
+-- | Find the fitting route for the given request.
+findRoute :: GeminiRequest -> Cana (Maybe Handler)
+findRoute req = do
+  routes <- asks serverRoutes
+  return $ snd <$> find (\(pred, _) -> pred req) routes
+
+-- | Run a TCP server.
+--
+-- Every client is forked with 'forkFinally'.
+--
+-- (Taken from the "network-run" package.)
+runTCPServer :: Maybe HostName -> ServiceName -> (Socket -> IO a) -> IO a
+runTCPServer mhost port server = withSocketsDo $ do
+    addr <- resolve
+    E.bracket (open addr) close loop
+  where
+    resolve = do
+        let hints = defaultHints {
+                addrFlags = [AI_PASSIVE]
+              , addrSocketType = Stream
+              }
+        head <$> getAddrInfo (Just hints) mhost (Just port)
+    open addr = do
+        sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+        setSocketOption sock ReuseAddr 1
+        withFdSocket sock setCloseOnExecIfNeeded
+        bind sock $ addrAddress addr
+        listen sock 1024
+        return sock
+    loop sock = forever $ do
+        (conn, _peer) <- accept sock
+        void $ forkFinally (server conn) (const $ gracefulClose conn 5000)
diff --git a/src/Cana/Monad.hs b/src/Cana/Monad.hs
new file mode 100644
index 0000000..e63e89a
--- /dev/null
+++ b/src/Cana/Monad.hs
@@ -0,0 +1,45 @@
+-- |
+-- Module     : Cana.Monad
+--
+-- This module contains the 'Cana' monad implementation.
+
+
+module Cana.Monad where
+
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Reader hiding (asks)
+import qualified Control.Monad.Trans.Reader
+import Control.Monad.Trans.Except hiding (except)
+import qualified Control.Monad.Trans.Except
+
+import Cana.Types
+
+-- | Run a computation in the 'Cana' monad.
+runCana :: GeminiServer -> Cana a -> IO (Either String a)
+runCana server (Cana r) = runExceptT $ runReaderT r server
+
+-- | Retrieve the 'GeminiServer' instance out of the 'Cana' monad.
+askGeminiServer :: Cana GeminiServer
+askGeminiServer = Cana ask
+
+-- | Retrieve the 'GeminiServer' but apply a function to the value before
+-- returning it.
+asks :: (GeminiServer -> a) -> Cana a
+asks = Cana . Control.Monad.Trans.Reader.asks
+
+-- | Wrap a fallible value into the 'Cana' monad.
+except :: Either String a -> Cana a
+except = Cana . lift . Control.Monad.Trans.Except.except
+
+-- | Fail with the given error value.
+throw :: String -> Cana a
+throw = Cana . lift . Control.Monad.Trans.Except.throwE
+
+-- | Log some information.
+logInfo :: MonadIO m => String -> m ()
+logInfo text = liftIO $ putStrLn ("[ INFO] " ++ text)
+
+-- | Log error information.
+logError :: MonadIO m => String -> m ()
+logError text = liftIO $ putStrLn ("\x1B[31m[ERROR]\x1B[m " ++ text)
diff --git a/src/Cana/Protocol.hs b/src/Cana/Protocol.hs
new file mode 100644
index 0000000..629353a
--- /dev/null
+++ b/src/Cana/Protocol.hs
@@ -0,0 +1,209 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- |
+-- Module     : Cana.Protocol
+--
+-- This module describes base types for interaction with the Gemini protocol.
+
+module Cana.Protocol
+    (
+    -- * Status codes
+      StatusCode
+    , fromInt
+    , toInt
+    -- ** Predefined status codes
+    , codeInput
+    , codeSensitiveInput
+    , codeSuccess
+    , codeRedirectTemporary
+    , codeRedirectPermanent
+    , codeTemporaryFailure
+    , codeServerUnavailable
+    , codeCGIError
+    , codeProxyError
+    , codeSlowDown
+    , codePermanentFailure
+    , codeNotFound
+    , codeGone
+    , codeProxyRequestRefused
+    , codeBadRequest
+    , codeClientCertRequired
+    , codeCertNotAuthorised
+    , codeCertNotValid
+    -- * Requests & Responses
+    , GeminiRequest(..)
+    , GeminiResponse(..)
+    , renderResponse
+    -- * Various things
+    , defaultGeminiPort
+    ) where
+
+import qualified Data.ByteString.Lazy as B
+import Data.ByteString.Builder
+import Data.X509 (CertificateChain)
+import Network.URI
+import Network.Socket (ServiceName)
+
+-- | A Gemini status code, a two digit integer.
+newtype StatusCode = StatusCode Int deriving (Eq, Show, Ord)
+
+-- | Converts an integer to a status code.
+--
+-- Returns 'Nothing' for integers that do not represent a valid status code.
+fromInt :: Int -> Maybe StatusCode
+fromInt code
+    | 10 <= code && code <= 99 = Just $ StatusCode code
+    | otherwise                = Nothing
+
+-- | Extracts the integer value out of a status code.
+toInt :: StatusCode -> Int
+toInt (StatusCode code) = code
+
+-- | INPUT status code.
+--
+-- This code signals the user that input is expected. The response meta field
+-- should provide a user-readable prompt.
+codeInput :: StatusCode
+codeInput = StatusCode 10
+
+-- | SENSITIVE INPUT status code.
+--
+-- The same as 'codeInput', but the user input should not be echoed back to the
+-- user.
+codeSensitiveInput :: StatusCode
+codeSensitiveInput = StatusCode 11
+
+-- | SUCCESS status code.
+--
+-- The request was handled successfully. The response meta field should contain
+-- the media MIME type of the response body.
+codeSuccess :: StatusCode
+codeSuccess = StatusCode 20
+
+-- | REDIRECT - TEMPORARY status code.
+--
+-- The requested resource was found at a different location. The response meta
+-- field should contain the new URL.
+codeRedirectTemporary :: StatusCode
+codeRedirectTemporary = StatusCode 30
+
+-- | REDIRECT - PERMANENT status code.
+--
+-- Same as 'codeRedirectTemporary', except that the resource should also be
+-- requested through the new URL in the future.
+codeRedirectPermanent :: StatusCode
+codeRedirectPermanent = StatusCode 31
+
+-- | TEMPORARY FAILURE status code.
+--
+-- The request has failed, but might succeed in the future. The response meta
+-- field may provide additional information to the user.
+codeTemporaryFailure :: StatusCode
+codeTemporaryFailure = StatusCode 40
+
+-- | SERVER UNAVAILABLE status code.
+--
+-- The server is unavailable, for example due to overload.
+codeServerUnavailable :: StatusCode
+codeServerUnavailable = StatusCode 41
+
+-- | CGI ERROR status code.
+--
+-- The process that generates content dynamically has died.
+codeCGIError :: StatusCode
+codeCGIError = StatusCode 42
+
+-- | PROXY ERROR status code.
+--
+-- A proxy request failed.
+codeProxyError :: StatusCode
+codeProxyError = StatusCode 42
+
+-- | SLOW DOWN status code.
+--
+-- The client is being rate limited. The response meta field gives the number
+-- of seconds that the client has to wait before it can issue the next request.
+codeSlowDown :: StatusCode
+codeSlowDown = StatusCode 44
+
+-- | PERMANENT FAILURE status code.
+--
+-- The request has failed and the reason is likely to be permanent. The
+-- response meta field can give a readable reason to the user.
+codePermanentFailure :: StatusCode
+codePermanentFailure = StatusCode 50
+
+-- | NOT FOUND status code.
+--
+-- The requested resource was not found (but may exist in the future).
+codeNotFound :: StatusCode
+codeNotFound = StatusCode 51
+
+-- | GONE status code.
+--
+-- The requested resource is no longer available.
+codeGone :: StatusCode
+codeGone = StatusCode 52
+
+-- | PROXY REQUEST REFUSED status code.
+--
+-- The requested resource lies at a different domain which the server does not
+-- serve or proxy.
+codeProxyRequestRefused :: StatusCode
+codeProxyRequestRefused = StatusCode 53
+
+-- | BAD REQUEST status code.
+--
+-- The client gave a malformed request.
+codeBadRequest :: StatusCode
+codeBadRequest = StatusCode 59
+
+-- | CLIENT CERTIFICATE REQUIRED status code.
+--
+-- The server expects a client certificate to be given. The response meta field
+-- may give a specific reason why a certificate is required.
+codeClientCertRequired :: StatusCode
+codeClientCertRequired = StatusCode 60
+
+-- | CERTIFICATE NOT AUTHORISED status code.
+--
+-- The supplied client certificate is not authorised.
+codeCertNotAuthorised :: StatusCode
+codeCertNotAuthorised = StatusCode 61
+
+-- | CERTIFICATE NOT VALID status code.
+--
+-- The given client certificate is invalid.
+codeCertNotValid :: StatusCode
+codeCertNotValid = StatusCode 62
+
+-- | A Gemini request.
+--
+-- Gemini requests usually only contain the URI that has been requested, which
+-- can be examined with 'requestUri'.
+--
+-- If the client sends a certificate, it can be saved in 'requestCert'.
+data GeminiRequest = GeminiRequest
+    { requestUri :: URI -- ^ The requested URI.
+    , requestCert :: Maybe CertificateChain -- ^ The client certificate, if given.
+    } deriving (Show, Eq)
+
+-- | A Gemini response.
+data GeminiResponse = GeminiResponse
+    { responseStatus :: StatusCode -- ^ The response status code.
+    , responseMeta :: B.ByteString -- ^ The meta information.
+    , responseData :: B.ByteString -- ^ The actual response.
+    }
+
+-- | Render a response to a 'ByteString', suitable to send over a socket.
+renderResponse :: GeminiResponse -> B.ByteString
+renderResponse rsp = toLazyByteString $ mconcat
+    [ intDec (toInt $ responseStatus rsp)
+    , charUtf8 ' '
+    , lazyByteString $ responseMeta rsp
+    , stringUtf8 "\r\n"
+    , lazyByteString $ responseData rsp
+    ]
+
+-- | The default Gemini port, as given in the specification.
+defaultGeminiPort :: ServiceName
+defaultGeminiPort = "1965"
diff --git a/src/Cana/Router.hs b/src/Cana/Router.hs
new file mode 100644
index 0000000..1454375
--- /dev/null
+++ b/src/Cana/Router.hs
@@ -0,0 +1,20 @@
+-- |
+-- Module     : Cana.Router
+
+module Cana.Router where
+
+import Cana.Types
+import Cana.Protocol
+import Cana.Monad
+
+import Network.URI
+
+-- | A predicate that always triggers, e.g. for catch-all routes.
+anyRoute :: Predicate
+anyRoute = const True
+
+-- | A predicate that matches the given hostname.
+routeHost :: String -> Predicate
+routeHost host request = case uriAuthority (requestUri request) of
+                           Nothing   -> False
+                           Just auth -> uriRegName auth == host
diff --git a/src/Cana/Server.hs b/src/Cana/Server.hs
new file mode 100644
index 0000000..3cff44a
--- /dev/null
+++ b/src/Cana/Server.hs
@@ -0,0 +1,43 @@
+-- |
+-- Module     : Cana.Server
+--
+-- This module contains types that are needed for the Cana Gemini server.
+
+module Cana.Server where
+
+import Cana.Types
+
+import Data.Default
+import Network.Socket (HostName, ServiceName)
+import qualified Network.TLS as TLS
+import qualified Network.TLS.Extra.Cipher as TE
+
+-- | Construct a Gemini server with the given credentials.
+--
+-- This ensures that the 'serverParams' are set up sensibly for the Gemini
+-- server to work.
+mkGeminiServer :: Maybe HostName -> ServiceName -> TLS.Credentials -> [Route] -> GeminiServer
+mkGeminiServer hostName port creds routes = GeminiServer
+    { serverCredentials = creds
+    , serverParams      = params
+    , serverHostName    = hostName
+    , serverPort        = port
+    , serverRoutes      = routes
+    }
+      where
+        params = def
+          { TLS.serverShared          = shared
+          , TLS.serverSupported       = supported
+          , TLS.serverHooks           = hooks
+          , TLS.serverWantClientCert  = True
+          }
+        shared = def
+          { TLS.sharedCredentials = creds
+          }
+        supported = def
+          { TLS.supportedVersions = [ TLS.TLS13, TLS.TLS12 ]
+          , TLS.supportedCiphers  = TE.ciphersuite_default
+          }
+        hooks = def
+          { TLS.onClientCertificate = const $ return TLS.CertificateUsageAccept
+          }
diff --git a/src/Cana/Types.hs b/src/Cana/Types.hs
new file mode 100644
index 0000000..250fcc1
--- /dev/null
+++ b/src/Cana/Types.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+-- |
+-- Module     : Cana.Types
+
+module Cana.Types where
+
+import Cana.Protocol
+
+import Network.Socket (HostName, ServiceName)
+import qualified Network.TLS as TLS
+import qualified Network.TLS.Extra.Cipher as TE
+
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Reader hiding (asks)
+import Control.Monad.Trans.Except hiding (except)
+
+-- | The Cana monad.
+--
+-- This is the monad that the server will run in.
+newtype Cana a = Cana (ReaderT GeminiServer (ExceptT String IO) a) deriving (Monad, Functor, Applicative, MonadIO)
+
+-- | The Gemini server information.
+--
+-- This has to be loaded and prepared once before the server starts its loop.
+-- Note that the server certificate is saved here, so any function that has
+-- access to this can also read the private key.
+data GeminiServer = GeminiServer
+    { serverCredentials :: TLS.Credentials -- ^ The server credentials.
+    , serverParams      :: TLS.ServerParams -- ^ The server TLS parameters.
+    , serverHostName    :: Maybe HostName -- ^ The 'HostName' that the server
+                                          -- should bind to.
+    , serverPort        :: String -- ^ The port ('ServiceName') that the server
+                                  -- should listen on.
+    , serverRoutes      :: [Route] -- ^ The routes that the server handles.
+    }
+
+-- | A predicate is a function that defines whether a route should match.
+type Predicate = GeminiRequest -> Bool
+-- | A handler is a function that generates a response for the given request.
+type Handler   = GeminiRequest -> Cana GeminiResponse
+-- | A route is a combination of a 'Predicate' and a 'Handler'
+type Route     = (Predicate, Handler)