gemini-server 0.1.0.0 → 0.2.0.0

raw patch · 3 files changed

+98/−37 lines, 3 filesdep +HsOpenSSLPVP ok

version bump matches the API change (PVP)

Dependencies added: HsOpenSSL

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• Network/Gemini/Server.hs +91/−34
• gemini-server.cabal +3/−3

@@ -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.

@@ -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-

@@ -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-