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.

16 files changed, 783 insertions, 0 deletions

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..c368d45
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,2 @@
+.stack-work/
+*~
\ No newline at end of file
diff --git a/Cana.cabal b/Cana.cabal
new file mode 100644
index 0000000..cc3c863
--- /dev/null
+++ b/Cana.cabal
@@ -0,0 +1,89 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.34.4.
+--
+-- see: https://github.com/sol/hpack
+
+name:           Cana
+version:        0.1.0.0
+description:    Please see the README on GitHub at <https://github.com/githubuser/Cana#readme>
+homepage:       https://github.com/githubuser/Cana#readme
+bug-reports:    https://github.com/githubuser/Cana/issues
+author:         Author name here
+maintainer:     example@example.com
+copyright:      2021 Author name here
+license:        BSD3
+license-file:   LICENSE
+build-type:     Simple
+extra-source-files:
+    README.md
+    ChangeLog.md
+
+source-repository head
+  type: git
+  location: https://github.com/githubuser/Cana
+
+library
+  exposed-modules:
+      Cana
+      Cana.Monad
+      Cana.Protocol
+      Cana.Router
+      Cana.Server
+      Cana.Types
+  other-modules:
+      Paths_Cana
+  hs-source-dirs:
+      src
+  build-depends:
+      base >=4.7 && <5
+    , bytestring
+    , data-default
+    , network
+    , network-uri
+    , tls
+    , transformers
+    , x509
+    , x509-store
+  default-language: Haskell2010
+
+executable Cana-exe
+  main-is: Main.hs
+  other-modules:
+      Paths_Cana
+  hs-source-dirs:
+      app
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      Cana
+    , base >=4.7 && <5
+    , bytestring
+    , data-default
+    , network
+    , network-uri
+    , tls
+    , transformers
+    , x509
+    , x509-store
+  default-language: Haskell2010
+
+test-suite Cana-test
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  other-modules:
+      Paths_Cana
+  hs-source-dirs:
+      test
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      Cana
+    , base >=4.7 && <5
+    , bytestring
+    , data-default
+    , network
+    , network-uri
+    , tls
+    , transformers
+    , x509
+    , x509-store
+  default-language: Haskell2010
diff --git a/ChangeLog.md b/ChangeLog.md
new file mode 100644
index 0000000..3d06f5d
--- /dev/null
+++ b/ChangeLog.md
@@ -0,0 +1,3 @@
+# Changelog for Cana
+
+## Unreleased changes
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..7caa388
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright Author name here (c) 2021
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Author name here nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..5637a52
--- /dev/null
+++ b/README.md
@@ -0,0 +1 @@
+# Cana
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
index 0000000..000726d
--- /dev/null
+++ b/app/Main.hs
@@ -0,0 +1,18 @@
+{-# 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)
+  ]
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)
diff --git a/stack.yaml b/stack.yaml
new file mode 100644
index 0000000..fadcb7e
--- /dev/null
+++ b/stack.yaml
@@ -0,0 +1,67 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+#
+# The location of a snapshot can be provided as a file or url. Stack assumes
+# a snapshot provided as a file might change, whereas a url resource does not.
+#
+# resolver: ./custom-snapshot.yaml
+# resolver: https://example.com/snapshots/2018-01-01.yaml
+resolver:
+  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/0.yaml
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+#   subdirs:
+#   - auto-update
+#   - wai
+packages:
+- .
+# Dependency packages to be pulled from upstream that are not in the resolver.
+# These entries can reference officially published versions as well as
+# forks / in-progress versions pinned to a git hash. For example:
+#
+# extra-deps:
+# - acme-missiles-0.3
+# - git: https://github.com/commercialhaskell/stack.git
+#   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#
+# extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=2.7"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor
diff --git a/stack.yaml.lock b/stack.yaml.lock
new file mode 100644
index 0000000..d4f3101
--- /dev/null
+++ b/stack.yaml.lock
@@ -0,0 +1,13 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+snapshots:
+- original:
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/0.yaml
+  completed:
+    sha256: c632012da648385b9fa3c29f4e0afd56ead299f1c5528ee789058be410e883c0
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/0.yaml
+    size: 585393
+packages: []
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
index 0000000..cd4753f
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,2 @@
+main :: IO ()
+main = putStrLn "Test suite not yet implemented"