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) )
type Request = URI
data Response = Response
{ Response -> Int
responseStatus :: Int
, Response -> String
responseMeta :: String
, Response -> ByteString
responseBody :: LBS.ByteString }
type Handler = Request -> IO Response
renderHeader :: Int -> String -> LBS.ByteString
Int
status String
meta =
String -> ByteString
forall a. IsString a => String -> a
fromString (Int -> String
forall a. Show a => a -> String
show Int
status) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
String -> ByteString
forall a. IsString a => String -> a
fromString String
" " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
String -> ByteString
forall a. IsString a => String -> a
fromString String
meta ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
String -> ByteString
forall a. IsString a => String -> a
fromString String
"\CR\LF"
runServer :: Maybe HostName -> ServiceName -> (Request -> IO Response) -> IO ()
runServer :: Maybe String -> String -> (Request -> IO Response) -> IO ()
runServer Maybe String
host String
service Request -> IO Response
handler = do
String -> (Logger -> Logger) -> IO ()
updateGlobalLogger String
"Network.Gemini.Server" ((Logger -> Logger) -> IO ()) -> (Logger -> Logger) -> IO ()
forall a b. (a -> b) -> a -> b
$ Priority -> Logger -> Logger
setLevel Priority
INFO
Maybe String -> String -> (Socket -> IO ()) -> IO ()
forall a. Maybe String -> String -> (Socket -> IO a) -> IO a
runTCPServer Maybe String
host String
service Socket -> IO ()
talk
where
talk :: Socket -> IO ()
talk Socket
s = do
String
msg <- ByteString -> String
toString (ByteString -> String) -> IO ByteString -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Socket -> Int64 -> IO ByteString
recv Socket
s Int64
1025
let mURI :: Maybe Request
mURI = String -> Maybe Request
parseURI (String -> Maybe Request) -> String -> Maybe Request
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'\CR', Char
'\LF'])) String
msg
SockAddr
peer <- Socket -> IO SockAddr
getPeerName Socket
s
case Maybe Request
mURI of
Maybe Request
Nothing -> do
Priority
-> SockAddr
-> Either String Request
-> Int
-> Maybe String
-> IO ()
logRequest Priority
INFO SockAddr
peer (String -> Either String Request
forall a b. a -> Either a b
Left String
msg) Int
59 Maybe String
forall a. Maybe a
Nothing
Socket -> ByteString -> IO ()
sendAll Socket
s (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String -> ByteString
renderHeader Int
59 (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. IsString a => String -> a
fromString String
"Invalid URL"
Just uri :: Request
uri@(URI String
"gemini:" Maybe URIAuth
_ String
_ String
_ String
_) -> do
Either SomeException Response
response <- IO Response -> IO (Either SomeException Response)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO Response -> IO (Either SomeException Response))
-> IO Response -> IO (Either SomeException Response)
forall a b. (a -> b) -> a -> b
$ Request -> IO Response
handler Request
uri
case Either SomeException Response
response of
Right (Response Int
status String
meta ByteString
body) -> do
Priority
-> SockAddr
-> Either String Request
-> Int
-> Maybe String
-> IO ()
logRequest Priority
INFO SockAddr
peer (Request -> Either String Request
forall a b. b -> Either a b
Right Request
uri) Int
status (Maybe String -> IO ()) -> Maybe String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
meta
Socket -> ByteString -> IO ()
sendAll Socket
s (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String -> ByteString
renderHeader Int
status String
meta
Socket -> ByteString -> IO ()
sendAll Socket
s ByteString
body
Left SomeException
e -> do
Priority
-> SockAddr
-> Either String Request
-> Int
-> Maybe String
-> IO ()
logRequest Priority
ERROR SockAddr
peer (Request -> Either String Request
forall a b. b -> Either a b
Right Request
uri) Int
42 (Maybe String -> IO ()) -> Maybe String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show (SomeException
e :: SomeException)
Socket -> ByteString -> IO ()
sendAll Socket
s (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String -> ByteString
renderHeader Int
42 (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. IsString a => String -> a
fromString String
"Internal server error"
Just uri :: Request
uri@(URI String
scheme Maybe URIAuth
_ String
_ String
_ String
_) -> do
Priority
-> SockAddr
-> Either String Request
-> Int
-> Maybe String
-> IO ()
logRequest Priority
INFO SockAddr
peer (Request -> Either String Request
forall a b. b -> Either a b
Right Request
uri) Int
59 Maybe String
forall a. Maybe a
Nothing
Socket -> ByteString -> IO ()
sendAll Socket
s (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String -> ByteString
renderHeader Int
59 (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. IsString a => String -> a
fromString (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"Invalid scheme: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
scheme
logRequest :: Priority -> SockAddr -> Either String URI -> Int -> Maybe String -> IO ()
logRequest :: Priority
-> SockAddr
-> Either String Request
-> Int
-> Maybe String
-> IO ()
logRequest Priority
p SockAddr
peer Either String Request
uri Int
code Maybe String
meta = String -> Priority -> String -> IO ()
logM String
"Network.Gemini.Server" Priority
p (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
[ SockAddr -> String
forall a. Show a => a -> String
show SockAddr
peer
, (String -> String)
-> (Request -> String) -> Either String Request -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> String
forall a. Show a => a -> String
show Request -> String
forall a. Show a => a -> String
show Either String Request
uri
, Int -> String
forall a. Show a => a -> String
show Int
code
, String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"-" String -> String
forall a. Show a => a -> String
show Maybe String
meta ]
okGemini :: LBS.ByteString -> Response
okGemini :: ByteString -> Response
okGemini = Int -> String -> ByteString -> Response
Response Int
20 (String -> ByteString -> Response)
-> String -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. IsString a => String -> a
fromString String
"text/gemini"
okPlain :: LBS.ByteString -> Response
okPlain :: ByteString -> Response
okPlain = Int -> String -> ByteString -> Response
Response Int
20 (String -> ByteString -> Response)
-> String -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. IsString a => String -> a
fromString String
"text/plain"
redirect :: URI -> Response
redirect :: Request -> Response
redirect Request
uri = Int -> String -> ByteString -> Response
Response Int
30 ((String -> String) -> Request -> String -> String
uriToString String -> String
forall a. a -> a
id Request
uri String
"") ByteString
forall a. Monoid a => a
mempty