ngnx.hs

{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, TemplateHaskell, DeriveGeneric, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleContexts, MultiParamTypeClasses, DataKinds, FlexibleInstances, StandaloneDeriving #-}

import Data.Text(Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Data.Attoparsec.Text
import Control.Applicative
import Control.Monad
import Data.Aeson(encode,ToJSON)
import Data.Typeable(Typeable)
import Data.Data(Data)
import qualified Data.ByteString.Lazy.Char8 as BS
import GHC.Generics
import Text.Parser.Combinators (endBy)

data Context = HttpContext | ServerContext | LocationContext | IfContext
    deriving (Show)

data Directive a where 
    ServerDirective :: [Directive 'ServerContext] -> Directive HttpContext
    ListenDirective :: Text -> Directive ServerContext
    ServerNameDirective :: [Text] -> Directive ServerContext
    IfDirective :: IfCondition -> [Directive 'IfContext] -> Directive a
    SetDirective :: Text -> Text -> Directive a
    LocationDirective :: LocationCondition -> [Directive 'LocationContext] -> Directive a
    InternalDirective :: Directive LocationContext
    RootDirective :: Text -> Directive a
    BreakDirective :: Directive a
    RewriteDirective :: Text -> Directive a
    ErrorPageDirective :: Integer -> Text -> Directive a
    AccessLogDirective :: Text -> Directive a
    ExpiresDirective :: Text -> Directive a
    UnknownDirective :: Text -> Text -> Directive a
    ProxyPassDirective :: Text -> Directive a
    ProxyHttpVersionDirective :: Text -> Directive a
    ProxySetHeaderDirective :: Text -> Directive a
    GzipDirective :: Text -> Directive a
    GzipCompLevelDirective :: Text -> Directive a
    GzipMinLengthDirective :: Text -> Directive a
    GzipDisableDirective :: Text -> Directive a
    GzipProxiedDirective :: Text -> Directive a

deriving instance Show (Directive a)

data IfCondition = IfVariable Text
                   | IfMatch Text MatchOp Text
                   | IfCompare Text EqOp Text
                   | IfFile Text
                   | IfDir Text
                   | IfExists Text
                   | IfExecutable Text
                   deriving (Show)

data LocationCondition = LocationUri (Maybe LocationOp) Text | LocationName Text deriving (Show)
data LocationOp = LocOpEquals | LocOpTilde | LocOpAsterisk deriving (Show)
data MatchOp = MatchOpAsterisk deriving (Show)
data EqOp = EqOpEquals | EqOpNotEquals deriving (Show)
data RewriteFlag = RewriteLast | RewriteBreak | RewriteRedirect | RewritePermanent deriving (Show)

server = ServerDirective <$> (string "server" *> some space *> char '{' *> (sepBy serverDirective (some space)) <* skipSpace <* char '}')

serverDirective = listen <|> serverName <|> ifD <|> location <|> errorPage <|> accessLog <|> expires
locationDirective = internal <|> root <|> Main.break <|> ifD <|> errorPage <|> accessLog <|> expires
             <|> proxyPass <|> proxyHttpVersion <|> proxySetHeader
             <|> gzipCompLevel <|> gzipMinLength <|> gzipDisable <|> gzipProxied <|> gzip
ifDirective = set <|> Main.break <|> rewrite <|> errorPage <|> accessLog <|> expires

internal = string "internal" *> char ';' *> return InternalDirective
root = RootDirective <$> (string "root" *> skipSpace *> takeWhile1 (/= ';') <* char ';')
break = string "break" *> char ';' *> return BreakDirective

-- todo
errorPage = ErrorPageDirective <$> (string "error_page" *> skipSpace *> decimal <* skipSpace) <*> (char '=' *> skipSpace *> (takeWhile1 (/= ';')) <* char ';')
keyValueDirective name = (string name *> skipSpace *> takeWhile1 (/= ';') <* char ';')
rewrite = RewriteDirective <$> keyValueDirective "rewrite" -- not really
accessLog = AccessLogDirective <$> keyValueDirective "access_log"
expires = ExpiresDirective <$> keyValueDirective "expires"
proxyPass = ProxyPassDirective <$> keyValueDirective "proxy_pass"
proxyHttpVersion = ProxyHttpVersionDirective <$> keyValueDirective "proxy_http_version"
proxySetHeader = ProxySetHeaderDirective <$> keyValueDirective "proxy_set_header"
gzip = GzipDirective <$> keyValueDirective "gzip"
gzipCompLevel = GzipCompLevelDirective <$> keyValueDirective "gzip_comp_level"
gzipMinLength = GzipMinLengthDirective <$> keyValueDirective "gzip_min_length"
gzipDisable = GzipDisableDirective <$> keyValueDirective "gzip_disable"
gzipProxied = GzipProxiedDirective <$> keyValueDirective "gzip_proxied"

-- never use this
unknownDirective = UnknownDirective <$> (takeWhile1 (/= ' ')) <*> (some space *> (takeWhile1 (/= ';')) <* char ';')

listen = ListenDirective <$> ((skipSpace *> string "listen" *> skipSpace *> takeWhile1 (/= ';')) <* char ';')

serverName = ServerNameDirective <$> ((skipSpace *> string "server_name" *> skipSpace *> (takeWhile1 (\c -> c /= ' ' && c /= ';')) `sepBy1` space) <* char ';')

ifD = skipSpace *> string "if" *> skipSpace *> char '(' *> skipSpace *> (ifMatch <|> ifCompare <|> ifVariable)
    where ifVariable = IfDirective <$> (IfVariable <$> variableName) <*> (char ')' *> ifBlock)
          ifCompare = IfDirective <$> (IfCompare <$> variableName <*> eqOp <*> takeWhile1 (/= ')')) <*> (char ')' *> ifBlock)
          ifMatch = do
                match <- IfMatch <$> variableName <*> matchOp
                (rest, ifb) <- followedBy anyChar (char ')' *> ifBlock)
                return $ IfDirective (match $ Text.pack rest) ifb
          ifBlock = skipSpace *> char '{' *> skipSpace *> (ifDirective `sepBy` (some space)) <* skipSpace <* char '}'
          eqOp = skipSpace *> ((char '=' *> return EqOpEquals) <|> (string "!=" *> return EqOpNotEquals)) <* skipSpace
          matchOp = skipSpace *> (string "~*" *> return MatchOpAsterisk) <* skipSpace

variableName = char '$' *> (Text.pack <$> some (letter <|> digit <|> char '_'))
set = SetDirective <$> (string "set" *> skipSpace *> variableName <* skipSpace) <*> takeWhile1 (/= ';') <* char ';' <* skipSpace

location = string "location" *> skipSpace *> (namedLocation <|> locationUri)
    where locationOp = skipSpace *> (opEquals <|> opAsterisk <|> opTilde) <* skipSpace
          opEquals = string "=" *> return LocOpEquals
          opTilde = string "~" *> return LocOpTilde
          opAsterisk = string "~*" *> return LocOpAsterisk
          locationName = LocationName <$> (char '@' *> (Text.pack <$> some (letter <|> digit <|> char '_'))) <* skipSpace
          locationUri = do 
                match <- LocationUri <$> optional locationOp 
                (rest, lb) <- followedBy anyChar locationBlock
                return $ LocationDirective (match $ Text.pack rest) lb
          namedLocation = LocationDirective <$> locationName <*> locationBlock
          locationBlock = skipSpace *> char '{' *> skipSpace *> (locationDirective `sepBy` (some space)) <* skipSpace <* char '}'



-- helpers
followedBy :: Alternative f => f a -> f b -> f ([a], b)
followedBy p end = scan
    where scan = ((,) <$> pure [] <*> end) <|> (\x (xs, e) -> (x:xs, e)) <$> p <*> scan


main = Text.readFile "nginx/sites-enabled/apatch.bget.ru" >>= \s -> parseTest server s