content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE TupleSections #-}
  
  module Program.Mighty.Route (
      -- * Paring a routing file
      parseRoute,
  
      -- * Types
      RouteDB,
      Route (..),
      Block (..),
      Src,
      Dst,
      Domain,
      Port,
  
      -- * RouteDBRef
      RouteDBRef,
      newRouteDBRef,
      readRouteDBRef,
      writeRouteDBRef,
  ) where
  
  import Control.Monad
  import Data.ByteString
  import qualified Data.ByteString.Char8 as BS
  import Data.IORef
  #ifdef DHALL
  import GHC.Natural (Natural)
  #endif
  import Network.Wai.Application.Classic
  import Text.Parsec
  import Text.Parsec.ByteString.Lazy
  
  import Program.Mighty.Parser
  
  ----------------------------------------------------------------
  
  -- | A logical path specified in URL.
  type Src = Path
  
  -- | A physical path in a file system.
  type Dst = Path
  
  type Domain = ByteString
  #ifdef DHALL
  type Port     = Natural
  #else
  type Port     = Int
  #endif
  
  data Block = Block [Domain] [Route] deriving (Eq, Show)
  data Route
      = RouteFile Src Dst
      | RouteRedirect Src Dst
      | RouteCGI Src Dst
      | RouteRevProxy Src Dst Domain Port
      deriving (Eq, Show)
  type RouteDB = [Block]
  
  ----------------------------------------------------------------
  
  -- | Parsing a route file.
  parseRoute
      :: FilePath
      -> Domain
      -- ^ A default domain, typically \"localhost\"
      -> Port
      -- ^ A default port, typically 80.
      -> IO RouteDB
  parseRoute file ddom dport = parseFile (routeDB ddom dport) file
  
  routeDB :: Domain -> Port -> Parser RouteDB
  routeDB ddom dport = commentLines *> many1 (block ddom dport) <* eof
  
  block :: Domain -> Port -> Parser Block
  block ddom dport = Block <$> cdomains <*> many croute
    where
      cdomains = domains <* commentLines
      croute = route ddom dport <* commentLines
  
  domains :: Parser [Domain]
  domains = open *> doms <* close <* trailing
    where
      open = () <$ char '[' *> spcs
      close = () <$ char ']' *> spcs
      doms = (domain `sepBy1` sep) <* spcs
      domain = BS.pack <$> many1 (noneOf "[], \t\n")
      sep = () <$ spcs1
  
  data Op = OpFile | OpCGI | OpRevProxy | OpRedirect
  
  route :: Domain -> Port -> Parser Route
  route ddom dport = do
      s <- src
      o <- op
      case o of
          OpFile -> RouteFile s <$> dst <* trailing
          OpRedirect -> RouteRedirect s <$> dst' <* trailing
          OpCGI -> RouteCGI s <$> dst <* trailing
          OpRevProxy -> do
              (dom, prt, d) <- domPortDst ddom dport
              return $ RouteRevProxy s d dom prt
    where
      src = path
      dst = path
      dst' = path'
      op0 =
          OpFile <$ string "->"
              <|> OpRedirect <$ string "<<"
              <|> OpCGI <$ string "=>"
              <|> OpRevProxy <$ string ">>"
      op = op0 <* spcs
  
  path :: Parser Path
  path = do
      c <- char '/'
      BS.pack . (c :) <$> many (noneOf "[], \t\n") <* spcs
  
  path' :: Parser Path
  path' = BS.pack <$> many (noneOf "[], \t\n") <* spcs
  
  -- [host1][:port2]/path2
  
  domPortDst :: Domain -> Port -> Parser (Domain, Port, Dst)
  domPortDst ddom dport =
      (ddom,,) <$> port <*> path
          <|> try ((,,) <$> domain <*> port <*> path)
          <|> (,dport,) <$> domain <*> path
    where
      domain = BS.pack <$> many1 (noneOf ":/[], \t\n")
      port = do
          void $ char ':'
          read <$> many1 (oneOf ['0' .. '9'])
  
  ----------------------------------------------------------------
  
  newtype RouteDBRef = RouteDBRef (IORef RouteDB)
  
  newRouteDBRef :: RouteDB -> IO RouteDBRef
  newRouteDBRef rout = RouteDBRef <$> newIORef rout
  
  readRouteDBRef :: RouteDBRef -> IO RouteDB
  readRouteDBRef (RouteDBRef ref) = readIORef ref
  
  writeRouteDBRef :: RouteDBRef -> RouteDB -> IO ()
  writeRouteDBRef (RouteDBRef ref) rout = writeIORef ref rout
  