gemini-server (empty) → 0.1.0.0

raw patch · 6 files changed

+174/−0 lines, 6 filesdep +basedep +bytestringdep +hsloggersetup-changed

Dependencies added: base, bytestring, hslogger, network, network-run, network-uri, text, utf8-string

Files

CHANGELOG.md +6/−0
LICENSE +30/−0
Network/Gemini/Server.hs +89/−0
README.md +9/−0
Setup.hs +2/−0
gemini-server.cabal +38/−0

+ CHANGELOG.md view

@@ -0,0 +1,6 @@+# Revision history for gemini-server++## 0.1.0.0 -- 2020-07-24++* First version. Released on an unsuspecting world.+

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2020, Francesco Gazzetta++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 Francesco Gazzetta 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.

+ Network/Gemini/Server.hs view

@@ -0,0 +1,89 @@+module Network.Gemini.Server (+  Request+, Response(..)+, Handler+, runServer+, okGemini+, okPlain+, redirect+) where++import Network.Socket (HostName, ServiceName, SockAddr, getPeerName)+import Network.Socket.ByteString.Lazy (recv, sendAll)+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.String (fromString)++import Control.Exception (SomeException, try)++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++data Response = Response+  { responseStatus :: Int+  , responseMeta :: String+  , responseBody :: LBS.ByteString }++type Handler = Request -> IO Response++renderHeader :: Int -> String -> LBS.ByteString+renderHeader status meta =+  fromString (show status) <>+  fromString " " <>+  fromString meta <>+  fromString "\CR\LF"++runServer :: Maybe HostName -> ServiceName -> (Request -> IO Response) -> IO ()+runServer host service handler = 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++logRequest :: Priority -> SockAddr -> Either String URI -> Int -> Maybe String -> IO ()+logRequest p peer uri code meta = logM "Network.Gemini.Server" p $ unwords+  [ show peer+  , either show show uri+  , show code+  , maybe "-" show meta ]++-- | Shorthand for @Response 20 "text/gemini"@+okGemini :: LBS.ByteString -> Response+okGemini = Response 20 $ fromString "text/gemini"++-- | Shorthand for @Response 20 "text/plain"@+okPlain :: LBS.ByteString -> Response+okPlain = Response 20 $ fromString "text/plain"++redirect :: URI -> Response+redirect uri = Response 30 (uriToString id uri "") mempty+

+ README.md view

@@ -0,0 +1,9 @@+# gemini-server++[![Hackage](https://img.shields.io/hackage/v/gemini-server.svg)](https://hackage.haskell.org/package/gemini-server)+[![builds.sr.ht status](https://builds.sr.ht/~fgaz/gemini-server.svg)](https://builds.sr.ht/~fgaz/gemini-server?)++**A lightweight Haskell server library for the Gemini protocol**++More info at https://sr.ht/~fgaz/haskell-gemini/+

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ gemini-server.cabal view

@@ -0,0 +1,38 @@+cabal-version:       2.2++name:                gemini-server+version:             0.1.0.0+synopsis:            A lightweight server for the Gemini protocol+description:+  This package contains a server for the+  Gemini (<https://gemini.circumlunar.space/>) protocol.+  There is no tls support yet, so you'll need a tls terminator like stunnel+  in front of it.+  For a higher level interface, see the gemini-router package.+homepage:            https://sr.ht/~fgaz/haskell-gemini/+bug-reports:         https://todo.sr.ht/~fgaz/haskell-gemini+license:             BSD-3-Clause+license-file:        LICENSE+author:              Francesco Gazzetta+maintainer:          Francesco Gazzetta <fgaz@fgaz.me>+copyright:           © 2020 Francesco Gazzetta and contributors+category:            Network, Gemini+extra-source-files:  CHANGELOG.md, README.md++source-repository head+  type:                git+  location:            https://git.sr.ht/~fgaz/gemini-server++library+  exposed-modules:     Network.Gemini.Server+  build-depends:       base ^>=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+                     , text ^>=1.2.3.2+                     , utf8-string ^>=1.0.1.1+                     , bytestring ^>=0.10.10.0+                     , hslogger ^>=1.3.1.0+  ghc-options:         -Wall+  default-language:    Haskell2010+