diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,6 @@ +# Revision history for gemini-server + +## 0.1.0.0 -- 2020-07-24 + +* First version. Released on an unsuspecting world. + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Network/Gemini/Server.hs b/Network/Gemini/Server.hs new file mode 100644 --- /dev/null +++ b/Network/Gemini/Server.hs @@ -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 + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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/ + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/gemini-server.cabal b/gemini-server.cabal new file mode 100644 --- /dev/null +++ b/gemini-server.cabal @@ -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 () 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 +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 +