module Network.Gemini.Server (
  Request(..)
, Response(..)
, Handler
, runServer
, okGemini
, okPlain
, redirect
) where

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.UTF8 (toString)

import Data.String (fromString)

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

-- | A Gemini client's request
--
-- @since 0.2.0.0
data Request = Request
  { Request -> URI
requestURI :: URI
  , Request -> Maybe X509
requestCert :: Maybe X509 }

-- | A Gemini server's response
--
-- @since 0.1.0.0
data Response = Response
  { Response -> Int
responseStatus :: Int
  , Response -> String
responseMeta :: String
  , Response -> ByteString
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
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"

-- | Start a Gemini server.
--
-- @since 0.2.0.0
runServer :: Maybe HostName
          -> ServiceName
          -> FilePath -- ^ Path to the server certificate
          -> FilePath -- ^ Path to the private key
          -> (Request -> IO Response) -- ^ Request handler
          -> IO ()
runServer :: Maybe String
-> String -> String -> String -> (Request -> IO Response) -> IO ()
runServer Maybe String
host String
service String
cert String
key Request -> IO Response
handler = IO () -> IO ()
forall a. IO a -> IO a
withOpenSSL (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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 server config
  SSLContext
sslCtx <- String -> String -> IO SSLContext
setupSSL String
cert String
key
  Maybe String -> String -> (Socket -> IO ()) -> IO ()
forall a. Maybe String -> String -> (Socket -> IO a) -> IO a
runTCPServer Maybe String
host String
service ((Socket -> IO ()) -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock -> do
    SockAddr
peer <- Socket -> IO SockAddr
getPeerName Socket
sock
    IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch -- the ssl session may fail
      (IO SSL -> (SSL -> IO ()) -> (SSL -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
        (SSLContext -> Socket -> IO SSL
acceptSSL SSLContext
sslCtx Socket
sock)
        (SSL -> ShutdownType -> IO ()
`SSL.shutdown` ShutdownType
SSL.Unidirectional)
        ((Request -> IO Response) -> SockAddr -> SSL -> IO ()
talk Request -> IO Response
handler SockAddr
peer))
      (\SomeException
e -> String -> Priority -> String -> IO ()
logM String
"Network.Gemini.Server" Priority
ERROR (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show (SomeException
e :: SomeException))

setupSSL :: FilePath -> FilePath -> IO SSL.SSLContext
setupSSL :: String -> String -> IO SSLContext
setupSSL String
cert String
key = do
  SSLContext
sslCtx <- IO SSLContext
SSL.context
  SSLContext -> IO ()
SSL.contextSetDefaultCiphers SSLContext
sslCtx
  SSLContext -> String -> IO ()
SSL.contextSetCertificateFile SSLContext
sslCtx String
cert
  SSLContext -> String -> IO ()
SSL.contextSetPrivateKeyFile SSLContext
sslCtx String
key
  SSLContext -> VerificationMode -> IO ()
SSL.contextSetVerificationMode SSLContext
sslCtx (VerificationMode -> IO ()) -> VerificationMode -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Maybe (Bool -> X509StoreCtx -> IO Bool)
-> VerificationMode
SSL.VerifyPeer Bool
False Bool
True (Maybe (Bool -> X509StoreCtx -> IO Bool) -> VerificationMode)
-> Maybe (Bool -> X509StoreCtx -> IO Bool) -> VerificationMode
forall a b. (a -> b) -> a -> b
$
    -- Accept all certificates, since we don't really care about validity wrt CAs
    -- but only about the public key
    (Bool -> X509StoreCtx -> IO Bool)
-> Maybe (Bool -> X509StoreCtx -> IO Bool)
forall a. a -> Maybe a
Just ((Bool -> X509StoreCtx -> IO Bool)
 -> Maybe (Bool -> X509StoreCtx -> IO Bool))
-> (Bool -> X509StoreCtx -> IO Bool)
-> Maybe (Bool -> X509StoreCtx -> IO Bool)
forall a b. (a -> b) -> a -> b
$ \Bool
_ X509StoreCtx
_ -> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  SSLContext -> ByteString -> IO ()
SSL.contextSetSessionIdContext SSLContext
sslCtx (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a. IsString a => String -> a
fromString String
"gemini-server"
  SSLContext -> IO SSLContext
forall (f :: * -> *) a. Applicative f => a -> f a
pure SSLContext
sslCtx

acceptSSL :: SSL.SSLContext -> Socket -> IO SSL
acceptSSL :: SSLContext -> Socket -> IO SSL
acceptSSL SSLContext
sslCtx Socket
sock = do
  SSL
ssl <- SSLContext -> Socket -> IO SSL
SSL.connection SSLContext
sslCtx Socket
sock
  SSL -> IO ()
SSL.accept SSL
ssl
  SSL -> IO SSL
forall (f :: * -> *) a. Applicative f => a -> f a
pure SSL
ssl

talk :: (Request -> IO Response) -> SockAddr -> SSL -> IO ()
talk :: (Request -> IO Response) -> SockAddr -> SSL -> IO ()
talk Request -> IO Response
handler SockAddr
peer SSL
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
<$> SSL -> Int -> IO ByteString
SSL.read SSL
s Int
1025 -- 1024 + CR or LF
  -- It makes sense to be very lenient here
  let mURI :: Maybe URI
mURI = String -> Maybe URI
parseURI (String -> Maybe URI) -> String -> Maybe URI
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
  case Maybe URI
mURI of
    Maybe URI
Nothing -> do
      Priority
-> SockAddr -> Either String URI -> Int -> Maybe String -> IO ()
logRequest Priority
INFO SockAddr
peer (String -> Either String URI
forall a b. a -> Either a b
Left String
msg) Int
59 Maybe String
forall a. Maybe a
Nothing
      SSL -> ByteString -> IO ()
SSL.lazyWrite SSL
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 :: URI
uri@(URI String
"gemini:" Maybe URIAuth
_ String
_ String
_ String
_) -> do
      Maybe X509
clientCert <- SSL -> IO (Maybe X509)
SSL.getPeerCertificate SSL
s
      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 -> IO Response) -> Request -> IO Response
forall a b. (a -> b) -> a -> b
$ URI -> Maybe X509 -> Request
Request URI
uri Maybe X509
clientCert
      case Either SomeException Response
response of
        Right (Response Int
status String
meta ByteString
body) -> do
          Priority
-> SockAddr -> Either String URI -> Int -> Maybe String -> IO ()
logRequest Priority
INFO SockAddr
peer (URI -> Either String URI
forall a b. b -> Either a b
Right URI
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
          SSL -> ByteString -> IO ()
SSL.lazyWrite SSL
s (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String -> ByteString
renderHeader Int
status String
meta
          SSL -> ByteString -> IO ()
SSL.lazyWrite SSL
s ByteString
body
        Left SomeException
e -> do
          Priority
-> SockAddr -> Either String URI -> Int -> Maybe String -> IO ()
logRequest Priority
ERROR SockAddr
peer (URI -> Either String URI
forall a b. b -> Either a b
Right URI
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)
          SSL -> ByteString -> IO ()
SSL.lazyWrite SSL
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 :: URI
uri@(URI String
scheme Maybe URIAuth
_ String
_ String
_ String
_) -> do
          Priority
-> SockAddr -> Either String URI -> Int -> Maybe String -> IO ()
logRequest Priority
INFO SockAddr
peer (URI -> Either String URI
forall a b. b -> Either a b
Right URI
uri) Int
59 Maybe String
forall a. Maybe a
Nothing
          SSL -> ByteString -> IO ()
SSL.lazyWrite SSL
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 URI -> Int -> Maybe String -> IO ()
logRequest Priority
p SockAddr
peer Either String URI
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)
-> (URI -> String) -> Either String URI -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> String
forall a. Show a => a -> String
show URI -> String
forall a. Show a => a -> String
show Either String URI
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"@
--
-- @since 0.1.0.0
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"@
--
-- @since 0.1.0.0
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"

-- | Shorthand for @Response 30 uri@
--
-- @since 0.1.0.0
redirect :: URI -> Response
redirect :: URI -> Response
redirect URI
uri = Int -> String -> ByteString -> Response
Response Int
30 ((String -> String) -> URI -> String -> String
uriToString String -> String
forall a. a -> a
id URI
uri String
"") ByteString
forall a. Monoid a => a
mempty