{-# 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)
-- >   ] >> return ()
--
-- 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.
-- * "Cana.Handlers" contains many pre-defined request handlers.

module Cana
    ( -- * High-Level API
      runGeminiServer
    , runGeminiServer'
      -- * Low-Level API
    , 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 (Either String ())
runGeminiServer hostName serviceName credFile keyFile routes = do
  creds <- loadCredentials credFile keyFile
  case creds of
    Left l      -> return $ Left l
    Right creds -> do
      let vhost = VirtualHost {
          vhostName        = "*"
        , vhostCredentials = creds
        , vhostRoutes      = routes
        }
      runGeminiServer' (mkGeminiServer hostName serviceName creds [vhost])

-- | Run the Gemini server.
--
-- This is a more advanced version of 'runGeminiServer' that takes in the
-- 'GeminiServer' directly. This allows more fine grained control at the cost
-- of more cumbersome setup (e.g. you have to load the credentials manually,
-- ...).
--
-- This function returns inner errors, if any occur.
runGeminiServer' :: GeminiServer -> IO (Either String ())
runGeminiServer' = flip runCana canaServer

-- | 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)