diff options
Diffstat (limited to 'app')
| -rw-r--r-- | app/Main.hs | 152 |
1 files changed, 46 insertions, 106 deletions
diff --git a/app/Main.hs b/app/Main.hs index f4c7afc..7e96dc8 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -4,8 +4,9 @@ {-# LANGUAGE TypeOperators #-} module Main where - -import Control.Applicative ( (<|>) ) +import Control.Applicative ( (<**>) + , (<|>) + ) import Control.Lens ( (^.) , (^?) ) @@ -24,36 +25,13 @@ import Data.Aeson.Lens ( AsNumber(..) , AsValue(..) , key ) -import Data.Attoparsec.Combinator ( lookAhead ) -import Data.Attoparsec.Text ( Parser - , anyChar - , char - , choice - , many' - , manyTill - , parse - , parseOnly - , sepBy - , skipMany - , skipSpace - , skipWhile - , space - , string - , takeTill - , takeWhile1 - ) import qualified Data.ByteString.Lazy as BSL -import Data.Char ( isAlpha - , isAlphaNum - ) import Data.Either ( fromRight ) import qualified Data.HashMap.Lazy as HM import Data.List ( find , isSuffixOf ) -import Data.Maybe ( catMaybes - , fromJust - ) +import Data.Maybe ( fromJust ) import Data.Proxy ( Proxy(..) ) import qualified Data.Text as T import Data.Text ( Text ) @@ -64,7 +42,25 @@ import Network.Wreq ( Response , get , responseBody ) +import Options.Applicative ( Parser + , auto + , execParser + , fullDesc + , header + , help + , helper + , info + , long + , metavar + , option + , progDesc + , short + , showDefault + , value + ) import Prelude hiding ( takeWhile ) +import Servall.Types +import Servall.WikiParser ( parseWikiTemplates ) import Servant ( (:<|>)(..) , (:>) , Application @@ -161,87 +157,9 @@ getInfobox name = do HM.empty wtFields (find (\(WikiTemplate name _) -> name == "Infobox") - (fromRight [] (parseOnly wikiP wiki)) + (fromRight [] (parseWikiTemplates wiki)) ) -wikiP :: Parser [WikiTemplate] -wikiP = sepBy templateP (commentP <|> skipSpace) - -data WikiTemplate = WikiTemplate - { wtName :: Text - -- , wtSubName :: Maybe Text - , wtFields :: HM.HashMap Text Text - } - deriving (Show, Generic) - -instance ToJSON WikiTemplate -instance FromJSON WikiTemplate - -templateP :: Parser WikiTemplate -templateP = do - string "{{" - name <- tempHeaderP - fields <- many' (choice [tempFieldP, commentP >> return Nothing]) - string "}}" - return $ WikiTemplate name (HM.fromList (catMaybes fields)) - -tempHeaderP :: Parser Text -tempHeaderP = do - -- Not sure whether name can contain numbers - skipSpace - -- Does not consider multiple words like Short description - name <- takeWhile1 isAlpha - manyTill anyChar (lookAhead ((char '|' >> return "") <|> string "}}")) - return name - -tempFieldP :: Parser (Maybe (Text, Text)) -tempFieldP = do - skipSpace >> char '|' >> skipSpace - choice [namedField, tempFieldValueP >> return Nothing] - where - namedField = do - key <- takeWhile1 (\c -> isAlphaNum c || c == '_') - skipSpace - char '=' - skipSpace - value <- tempFieldValueP - return $ if T.null value then Nothing else Just (key, value) - -tempFieldValueP :: Parser Text -tempFieldValueP = do - skipSpace - T.concat <$> many' - (choice [templateP >> return "", commentP >> return "", wikilinkP, simpleP]) - where - simpleP :: Parser Text - simpleP = do - t <- T.pack <$> manyTill - anyChar - (lookAhead - ( string "[[" - <|> string "{{" - <|> string "<!--" - <|> (char '|' >> return "") - <|> string "}}" - ) - ) - if T.null t then fail "simpleP" else return $ T.unwords $ T.words t - -commentP :: Parser () -commentP = do - skipSpace >> string "<!--" >> untilCommentEnd "" - where - untilCommentEnd :: Text -> Parser () - untilCommentEnd xs | T.isSuffixOf "--" xs = char '>' >> return () - untilCommentEnd _ = do - xs <- takeWhile1 (/= '>') - untilCommentEnd xs - -wikilinkP :: Parser Text -wikilinkP = do - beg <- string "[[" - content <- T.pack <$> manyTill anyChar (string "]]") - return $ beg <> content <> "]]" app :: Application app = serve api server @@ -251,4 +169,26 @@ api = Proxy main :: IO () main = do - run 5555 app + config <- execParser opts + run (configPort config) app + where + opts = info + (optParser <**> helper) + (fullDesc <> progDesc "Servall everything server" <> header + "servall - an everything server." + ) + +optParser :: Parser ServerConfig +optParser = ServerConfig <$> option + auto + ( long "port" + <> short 'p' + <> metavar "PORT" + <> value 5555 + <> showDefault + <> help "Port to run the server at." + ) + +data ServerConfig = ServerConfig + { configPort :: Int + } |