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
  { Response -> Int
responseStatus :: Int
  , Response -> String
responseMeta :: String
  , Response -> ByteString
responseBody :: LBS.ByteString }

type Handler = Request -> IO Response

renderHeader :: Int -> String -> LBS.ByteString
renderHeader :: Int -> String -> ByteString
renderHeader 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 -- MAYBE server config
  where
    talk :: Socket -> IO ()
talk Socket
s = do --TODO timeouts on send and receive (and maybe on handler)
      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 -- 1024 + CR or LF
      -- It makes sense to be very lenient here
      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 ]

-- | Shorthand for @Response 20 "text/gemini"@
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"

-- | Shorthand for @Response 20 "text/plain"@
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