diff options
| -rw-r--r-- | .gitignore | 2 | ||||
| -rw-r--r-- | Cana.cabal | 89 | ||||
| -rw-r--r-- | ChangeLog.md | 3 | ||||
| -rw-r--r-- | LICENSE | 30 | ||||
| -rw-r--r-- | README.md | 1 | ||||
| -rw-r--r-- | Setup.hs | 2 | ||||
| -rw-r--r-- | app/Main.hs | 18 | ||||
| -rw-r--r-- | src/Cana.hs | 196 | ||||
| -rw-r--r-- | src/Cana/Monad.hs | 45 | ||||
| -rw-r--r-- | src/Cana/Protocol.hs | 209 | ||||
| -rw-r--r-- | src/Cana/Router.hs | 20 | ||||
| -rw-r--r-- | src/Cana/Server.hs | 43 | ||||
| -rw-r--r-- | src/Cana/Types.hs | 43 | ||||
| -rw-r--r-- | stack.yaml | 67 | ||||
| -rw-r--r-- | stack.yaml.lock | 13 | ||||
| -rw-r--r-- | test/Spec.hs | 2 |
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 @@ -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" |