diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for gemini-server +## 0.2.0.0 -- 2021-02-22 + +* SSL/TLS support, including client certificates. + ## 0.1.0.0 -- 2020-07-24 * First version. Released on an unsuspecting world. diff --git a/Network/Gemini/Server.hs b/Network/Gemini/Server.hs --- a/Network/Gemini/Server.hs +++ b/Network/Gemini/Server.hs @@ -1,5 +1,5 @@ module Network.Gemini.Server ( - Request + Request(..) , Response(..) , Handler , runServer @@ -8,30 +8,46 @@ , redirect ) where -import Network.Socket (HostName, ServiceName, SockAddr, getPeerName) -import Network.Socket.ByteString.Lazy (recv, sendAll) +import Network.Socket (Socket, HostName, ServiceName, SockAddr, getPeerName) +import OpenSSL (withOpenSSL) +import qualified OpenSSL.Session as SSL +import OpenSSL.Session (SSL) +import OpenSSL.X509 (X509) import Network.Run.TCP (runTCPServer) import Network.URI (URI(URI), parseURI, uriToString) import qualified Data.ByteString.Lazy as LBS -import Data.ByteString.Lazy.UTF8 (toString) +import Data.ByteString.UTF8 (toString) import Data.String (fromString) -import Control.Exception (SomeException, try) +import Control.Exception (SomeException, try, bracket, catch) import System.Log.Logger ( updateGlobalLogger, setLevel, logM, Priority(INFO, ERROR) ) + --MAYBE switch to a more modern/efficient uri library ---TODO add client cert -type Request = URI +-- | A Gemini client's request +-- +-- @since 0.2.0.0 +data Request = Request + { requestURI :: URI + , requestCert :: Maybe X509 } + +-- | A Gemini server's response +-- +-- @since 0.1.0.0 data Response = Response { responseStatus :: Int , responseMeta :: String , responseBody :: LBS.ByteString } +-- | A request handler specifies how the server should respond to the clients' +-- requests +-- +-- @since 0.1.0.0 type Handler = Request -> IO Response renderHeader :: Int -> String -> LBS.ByteString @@ -41,34 +57,69 @@ fromString meta <> fromString "\CR\LF" -runServer :: Maybe HostName -> ServiceName -> (Request -> IO Response) -> IO () -runServer host service handler = do +-- | Start a Gemini server. +-- +-- @since 0.2.0.0 +runServer :: Maybe HostName + -> ServiceName + -> FilePath -- ^ Path to the server certificate + -> (Request -> IO Response) -- ^ Request handler + -> IO () +runServer host service cert handler = withOpenSSL $ do updateGlobalLogger "Network.Gemini.Server" $ setLevel INFO - runTCPServer host service talk -- MAYBE server config - where - talk s = do --TODO timeouts on send and receive (and maybe on handler) - msg <- toString <$> recv s 1025 -- 1024 + CR or LF - -- It makes sense to be very lenient here - let mURI = parseURI $ takeWhile (not . (`elem` ['\CR', '\LF'])) msg - peer <- getPeerName s - case mURI of - Nothing -> do - logRequest INFO peer (Left msg) 59 Nothing - sendAll s $ renderHeader 59 $ fromString "Invalid URL" - Just uri@(URI "gemini:" _ _ _ _) -> do - response <- try $ handler uri - case response of - Right (Response status meta body) -> do - logRequest INFO peer (Right uri) status $ Just meta - sendAll s $ renderHeader status meta - sendAll s body - Left e -> do - logRequest ERROR peer (Right uri) 42 $ Just $ show (e :: SomeException) - sendAll s $ renderHeader 42 $ fromString "Internal server error" - Just uri@(URI scheme _ _ _ _) -> do - logRequest INFO peer (Right uri) 59 Nothing - sendAll s $ renderHeader 59 $ fromString $ "Invalid scheme: " <> scheme + -- MAYBE server config + sslCtx <- setupSSL cert + runTCPServer host service $ \sock -> do + peer <- getPeerName sock + catch -- the ssl session may fail + (bracket + (acceptSSL sslCtx sock) + (`SSL.shutdown` SSL.Unidirectional) + (talk handler peer)) + (\e -> logM "Network.Gemini.Server" ERROR $ show (e :: SomeException)) +setupSSL :: FilePath -> IO SSL.SSLContext +setupSSL cert = do + sslCtx <- SSL.context + SSL.contextSetDefaultCiphers sslCtx + SSL.contextSetCertificateFile sslCtx cert + SSL.contextSetPrivateKeyFile sslCtx cert + SSL.contextSetVerificationMode sslCtx $ SSL.VerifyPeer False True $ + -- Accept all certificates, since we don't really care about validity wrt CAs + -- but only about the public key + Just $ \_ _ -> pure True + pure sslCtx + +acceptSSL :: SSL.SSLContext -> Socket -> IO SSL +acceptSSL sslCtx sock = do + ssl <- SSL.connection sslCtx sock + SSL.accept ssl + pure ssl + +talk :: (Request -> IO Response) -> SockAddr -> SSL -> IO () +talk handler peer s = do --TODO timeouts on send and receive (and maybe on handler) + msg <- toString <$> SSL.read s 1025 -- 1024 + CR or LF + -- It makes sense to be very lenient here + let mURI = parseURI $ takeWhile (not . (`elem` ['\CR', '\LF'])) msg + case mURI of + Nothing -> do + logRequest INFO peer (Left msg) 59 Nothing + SSL.lazyWrite s $ renderHeader 59 $ fromString "Invalid URL" + Just uri@(URI "gemini:" _ _ _ _) -> do + clientCert <- SSL.getPeerCertificate s + response <- try $ handler $ Request uri clientCert + case response of + Right (Response status meta body) -> do + logRequest INFO peer (Right uri) status $ Just meta + SSL.lazyWrite s $ renderHeader status meta + SSL.lazyWrite s body + Left e -> do + logRequest ERROR peer (Right uri) 42 $ Just $ show (e :: SomeException) + SSL.lazyWrite s $ renderHeader 42 $ fromString "Internal server error" + Just uri@(URI scheme _ _ _ _) -> do + logRequest INFO peer (Right uri) 59 Nothing + SSL.lazyWrite s $ renderHeader 59 $ fromString $ "Invalid scheme: " <> scheme + logRequest :: Priority -> SockAddr -> Either String URI -> Int -> Maybe String -> IO () logRequest p peer uri code meta = logM "Network.Gemini.Server" p $ unwords [ show peer @@ -77,13 +128,19 @@ , maybe "-" show meta ] -- | Shorthand for @Response 20 "text/gemini"@ +-- +-- @since 0.1.0.0 okGemini :: LBS.ByteString -> Response okGemini = Response 20 $ fromString "text/gemini" -- | Shorthand for @Response 20 "text/plain"@ +-- +-- @since 0.1.0.0 okPlain :: LBS.ByteString -> Response okPlain = Response 20 $ fromString "text/plain" +-- | Shorthand for @Response 30 uri@ +-- +-- @since 0.1.0.0 redirect :: URI -> Response redirect uri = Response 30 (uriToString id uri "") mempty - diff --git a/gemini-server.cabal b/gemini-server.cabal --- a/gemini-server.cabal +++ b/gemini-server.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: gemini-server -version: 0.1.0.0 +version: 0.2.0.0 synopsis: A lightweight server for the Gemini protocol description: This package contains a server for the @@ -25,7 +25,7 @@ library exposed-modules: Network.Gemini.Server - build-depends: base ^>=4.13.0.0 || ^>=4.14.0.0 + build-depends: base ^>=4.12.0.0 || ^>=4.13.0.0 || ^>=4.14.0.0 , network ^>=3.1.1.1 , network-run ^>=0.2.3 , network-uri ^>=2.6.3.0 || ^>=2.7.0.0 @@ -33,6 +33,6 @@ , utf8-string ^>=1.0.1.1 , bytestring ^>=0.10.10.0 , hslogger ^>=1.3.1.0 + , HsOpenSSL ^>=0.11.5.1 ghc-options: -Wall default-language: Haskell2010 -