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.

1 files changed, 196 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)