{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module  : Cana
-- License : BSD3
--
-- "Cana" is a library implementing a [Project
-- Gemini](https://gemini.circumlunar.space/docs/specification.html) server.
-- The main goal of "Cana" is to provide a simple way for other applications to
-- run a Gemini server, as it can be as simple as a few lines of code:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > module Main where
-- >
-- > import Cana
-- > import Cana.Protocol
-- > import Cana.Router
-- >
-- > defaultResponse :: GeminiResponse
-- > defaultResponse = GeminiResponse
-- >   { responseStatus = codeSuccess
-- >   , responseMeta   = "text/gemini"
-- >   , responseData   = "# Hello World\nThis page was served by Cana."
-- >   }
-- >
-- > main :: IO ()
-- > main = runGeminiServer Nothing defaultGeminiPort "certificate.crt" "private.key"
-- >   [ (anyRoute, const $ return defaultResponse)
-- >   ]
--
-- Note that the module is split in a few different submodules:
--
-- * "Cana.Server" contains the server settings setup function.
-- * "Cana.Monad" contains function for working with the 'Cana' monad.
-- * "Cana.Types" defines all necessary types.
-- * "Cana.Protocol" contains low-level protocol definitions from the
--   specification, such as a variety of status codes.
-- * "Cana.Router" defines functions for defining 'Route's.

module Cana
    ( -- * High-Level API
      runGeminiServer
      -- * Low-Level API
    , loadCredentials
    , canaServer
    , canaClient
    , writeResponse
    ) where

import Cana.Server
import Cana.Monad
import Cana.Types
import Cana.Protocol
import Cana.Router

import Data.List
import Data.Maybe
import Control.Monad.IO.Class
import Control.Concurrent (forkFinally)
import qualified Control.Exception as E
import Control.Monad (unless, forever, void)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Char8 as C
import Network.Socket
import Network.URI

import qualified Network.TLS as TLS

-- | Run the Gemini server.
--
-- This is your one-stop-shop to quickly get a Gemini server running.
--
-- If you need finer grained control, check the other functions defined in this
-- module.
runGeminiServer :: Maybe HostName -- ^ Hostname to bind to.
                -> ServiceName    -- ^ Service name to listen on.
                -> FilePath       -- ^ Certificate key file.
                -> FilePath       -- ^ Private key file.
                -> [Route]        -- ^ Server routes.
                -> IO ()
runGeminiServer hostName serviceName credFile keyFile routes = do
  creds <- loadCredentials credFile keyFile
  let vhost = VirtualHost {
      vhostName        = "*"
    , vhostCredentials = creds
    , vhostRoutes      = routes
    }
  result <- runCana (mkGeminiServer hostName serviceName creds [vhost]) canaServer
  case result of
    Right _ -> return ()
    Left  s -> fail s

-- | Load the credentials.
--
-- This uses 'fail' if the loading of the credentials fails.
loadCredentials :: FilePath -- ^ Certificate file path.
                -> FilePath -- ^ Private key file path.
                -> IO TLS.Credentials -- ^ The loaded credentials.
loadCredentials certFile keyFile = do
  creds <- TLS.credentialLoadX509 "certificate.crt" "private.key" >>= unwrap
  return $ TLS.Credentials [creds]
    where
      unwrap :: Either String a -> IO a
      unwrap (Left s) = fail s
      unwrap (Right x) = pure x

-- | Run the actual Gemini server.
--
-- Note that the server parameters are available through the 'Cana' monad, so
-- you have to use 'runCana' in combination with 'mkGeminiServer' to set up the
-- correct parameters.
canaServer :: Cana ()
canaServer = do
  server <- askGeminiServer
  liftIO $ runTCPServer (serverHostName server) (serverPort server) (handleClient server)
    where
      handleClient server connection = do
        result <- runCana server (canaClient connection)
        case result of
          Right _ -> pure ()
          Left s  -> logError s

-- | Handler function for a single Gemini client.
--
-- This function sets up the TLS context, reads the request and computes the
-- reply. This function should be called with 'forkFinally' to not block other
-- clients.
--
-- If you have a listening socket already set up, this is the function that you
-- want to use in order to handle a single Gemini client connection.
canaClient :: Socket -> Cana ()
canaClient socket = do
  params <- asks serverParams
  -- Set up TLS context
  context <- TLS.contextNew socket params
  TLS.handshake context
  -- Parse request
  clientCert <- liftIO $ TLS.getClientCertificateChain context
  request <- BS.takeWhile (\c -> c /= 10 && c /= 13) <$> TLS.recvData context
  uri <- case parseURI $ C.unpack request of
           Just u  -> pure u
           Nothing -> do
             writeResponse context $ GeminiResponse
               { responseStatus = codeBadRequest
               , responseMeta   = BSL.empty
               , responseData   = BSL.empty
               }
             throw "Malformed client request"
  -- Acquire resource
  logInfo ("Request: " ++ show uri)
  let geminiRequest = GeminiRequest {
        requestUri  = uri
      , requestCert = clientCert
      }
  route <- findRoute geminiRequest
  case route of
    Just r  -> do
      response <- uncatch $ r geminiRequest
      case response of
        Left l -> do
          writeResponse context $ GeminiResponse
            { responseStatus = codeTemporaryFailure
            , responseMeta   = "Internal server error"
            , responseData   = ""
            }
          throw l
        Right r -> writeResponse context r
    Nothing -> do
      writeResponse context $ GeminiResponse
        { responseStatus = codeNotFound
        , responseMeta   = ""
        , responseData   = ""
        }

-- | Render a response and write it to the TLS encrypted socket.
writeResponse :: TLS.Context -> GeminiResponse -> Cana ()
writeResponse context = TLS.sendData context . renderResponse

-- | Find the fitting route for the given request.
findRoute :: GeminiRequest -> Cana (Maybe Handler)
findRoute req = do
  vhosts <- asks serverVHosts
  let hostName = maybe "" uriRegName . uriAuthority $ requestUri req
      vhost    = findVHost hostName vhosts
      routes   = maybe [] vhostRoutes vhost
  return $ snd <$> findIt routes
    where
      findIt = find (\(pred, _) -> pred req)

-- | Run a TCP server.
--
-- Every client is forked with 'forkFinally'.
--
-- (Taken from the "network-run" package.)
runTCPServer :: Maybe HostName -> ServiceName -> (Socket -> IO a) -> IO a
runTCPServer mhost port server = withSocketsDo $ do
    addr <- resolve
    E.bracket (open addr) close loop
  where
    resolve = do
        let hints = defaultHints {
                addrFlags = [AI_PASSIVE]
              , addrSocketType = Stream
              }
        head <$> getAddrInfo (Just hints) mhost (Just port)
    open addr = do
        sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
        setSocketOption sock ReuseAddr 1
        withFdSocket sock setCloseOnExecIfNeeded
        bind sock $ addrAddress addr
        listen sock 1024
        return sock
    loop sock = forever $ do
        (conn, _peer) <- accept sock
        void $ forkFinally (server conn) (const $ gracefulClose conn 5000)