haskyapi (empty) → 0.0.0.1
raw patch · 15 files changed
+1136/−0 lines, 15 filesdep +aesondep +basedep +blaze-html
Dependencies added: aeson, base, blaze-html, bytestring, containers, directory, haskyapi, http-conduit, markdown, mtl, network, parsec, persistent, persistent-sqlite, persistent-template, split, tagsoup, text, time, utf8-string
Files
- LICENSE +21/−0
- README.md +58/−0
- app/Api/Hapi.hs +71/−0
- app/Main.hs +9/−0
- app/Model.hs +94/−0
- app/ModelDef.hs +6/−0
- haskyapi.cabal +127/−0
- src/Web/Haskyapi.hs +201/−0
- src/Web/Haskyapi/Config/Config.hs +50/−0
- src/Web/Haskyapi/Config/Defaults.hs +12/−0
- src/Web/Haskyapi/Config/Parser.hs +60/−0
- src/Web/Haskyapi/Console/Cli.hs +202/−0
- src/Web/Haskyapi/Header.hs +200/−0
- src/Web/Haskyapi/Tool.hs +18/−0
- test/Spec.hs +7/−0
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2017 okue++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,58 @@+<img src="https://raw.githubusercontent.com/okue/Haskyapi/master/html/img/logo.png" width="60%">++[](https://travis-ci.org/okue/Haskyapi)++## What is Haskyapi?++Haskyapi is a HTTP server implemented in Haskell.++### Build++```sh+$ stack build+$ stack install+$ haskyapi migrate+$ haskyapi runserver -p 8080 -r .+root: .+listen on 8080+http://localhost:8080/+http://localhost:8080/index.html+http://localhost:8080/hoge.md+```++or++```sh+$ cabal build+```++### Options++- `-p, --port` : port number+- `-r, --root` : root directory+- `-h, --help` : help+++`setting.yml` is a configuration file for these options.+++## TODO++- [x] Open Markdown file+- [ ] Use Database easily+- [ ] Implement RESTful api easily+- [ ] Automatic generator of api reference document+- [ ] HTTPS++## Bash-completion++`.haskyapi.bash` is a bash-completion setting file for **haskyapi** command.++## Now++Haskyapi works at [okue.site:80](http://okue.site/)++- [Simple TODO](http://ftodo.okue.site/)+- [/markdown-page.md](http://okue.site/markdown-page.md)+- [/api/title?url=https://github.com/okue/Haskyapi](http://okue.site/api/title?url=https://github.com/okue/Haskyapi)+
+ app/Api/Hapi.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE MultiWayIf #-}+module Api.Hapi (+ routing,+) where++import qualified Codec.Binary.UTF8.String as B8+import qualified Data.ByteString.Lazy.Char8 as LC+import Text.HTML.TagSoup (parseTags, Tag(..))+import Network.HTTP.Simple+import Control.Applicative+import Data.Maybe (catMaybes)+import Data.Aeson++import qualified Web.Haskyapi.Tool as Tool+import Web.Haskyapi.Header (+ Api,+ ApiFunc,+ Method(..),+ ContentType(..)+ )++-- import Foreign.C.Types+-- import Foreign.C.String+-- foreign import ccall "math.h sin" c_sin :: Double -> Double+-- foreign import ccall "add" c_add :: CInt -> CInt -> CInt+-- foreign import ccall "two" c_two :: CInt+-- foreign import ccall "moji" c_moji :: CInt -> CString++routing :: [Api]+routing = [+ (GET, "/test", test GET, Cplain)+ ,(POST, "/test", test POST, Cplain)+ ,(GET, "/add", add, Cplain)+ ,(GET, "/title", title, Cplain)+ ,(POST, "/title", title, Cplain)+ ]++title :: ApiFunc+title qry _ =+ let x = lookup "url" qry in+ case x of+ Nothing -> return "Please query parameter of \"url\" in the form of ?url=https://hoge.com"+ Just url ->+ case Tool.getFileExt url of+ Just "pdf" ->+ return $ Tool.basename url+ _ ->+ B8.decodeString . LC.unpack . findTitle . parseTags . getResponseBody <$> (httpLBS =<< parseRequest url)+ where+ findTitle (TagOpen "title" _ : TagText x : xs) = x+ findTitle (TagOpen "TITLE" _ : TagText x : xs) = x+ findTitle [] = "no title"+ findTitle (x:xs) = findTitle xs+++test :: Method -> ApiFunc+test GET qry _ = return "ok from haskell api.\nThis is GET."+test POST qry _ = return "ok from haskell api.\nThis is POST."+++add :: ApiFunc+add qry _ =+ let x' = lookup "x" qry+ y' = lookup "y" qry in+ return $ case (x',y') of+ (Nothing,_) -> "No value of x."+ (_,Nothing) -> "No value of y."+ (Just x, Just y) -> show $ read x + read y+
+ app/Main.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE BangPatterns #-}+module Main where++import Model (migrateAndInit)+import qualified Api.Hapi as Hapi+import Web.Haskyapi.Console.Cli (haskyapi, haskyapiM)++-- main = haskyapiM Hapi.routing migrateAndInit+main = haskyapi Hapi.routing
+ app/Model.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}+{-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-}+{-# LANGUAGE EmptyDataDecls, MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Model (+ lookupMenu,+ lookupCoupon,+ migrateAndInit,+) where++import Data.Maybe (listToMaybe)+import Control.Monad.Reader (ReaderT)+-- import Control.Monad.IO.Class (liftIO)+import Database.Persist+import Database.Persist.TH+import Database.Persist.Sqlite++import qualified Web.Haskyapi.Config.Config as Config+import ModelDef++share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|+ Menu+ key Int+ price Int+ size Size+ deriving Show+ Coupon+ key String+ target Int+ off Int+ deriving Show+ SetMenu+ key Int+ menu [Int]+ deriving Show+|]++lookupTemplate f g = do+ cdb <- Config.db+ runSqlite cdb . aux $ listToMaybe . map (f . entityVal) <$> g+ where+ aux :: ReaderT SqlBackend m a -> ReaderT SqlBackend m a+ aux = id++lookupCoupon :: String -> IO (Maybe Coupon)+lookupCoupon x =+ lookupTemplate id $ selectList [CouponKey ==. x] [LimitTo 1]++lookupMenu :: Int -> IO (Maybe Int)+lookupMenu x =+ lookupTemplate menuPrice $ selectList [MenuKey ==. x] [LimitTo 1]++migrateAndInit :: IO ()+migrateAndInit = do+ cdb <- Config.db+ runSqlite cdb $ do+ runMigration migrateAll+ mapM_ insert [+ Menu 101 100 S,+ Menu 102 130 S,+ Menu 103 320 S,+ Menu 104 320 S,+ Menu 105 380 S,+ Menu 201 150 S,+ Menu 202 270 S,+ Menu 203 320 S,+ Menu 204 280 S,+ Menu 301 100 S,+ Menu 302 220 S,+ Menu 303 250 S,+ Menu 304 150 S,+ Menu 305 240 S,+ Menu 306 270 S,+ Menu 307 100 S,+ Menu 308 150 S+ ]+ mapM_ insert [+ Coupon "C001" 202 120,+ Coupon "C002" 203 170,+ Coupon "C003" 103 50,+ Coupon "C004" 502 70,+ Coupon "C005" 503 80,+ Coupon "C006" 308 50+ ]++main :: IO ()+main = do+ migrateAndInit+ print =<< lookupMenu 101+ print =<< lookupMenu 201+ print =<< lookupMenu 301+ print =<< lookupMenu 901+ print =<< lookupCoupon "C001"+ print =<< lookupCoupon "C004"
+ app/ModelDef.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module ModelDef where+import Database.Persist.TH (derivePersistField)++data Size = S | M | L deriving (Show, Read, Eq)+derivePersistField "Size"
+ haskyapi.cabal view
@@ -0,0 +1,127 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 23fca1f928d50c27458e9b0ae3906f6fdf1eedfe8923e316b5deb55cbb72b3ca++name: haskyapi+version: 0.0.0.1+synopsis: HTTP server+description: Please see the README on Github at <https://github.com/okue/haskyapi#readme>+category: Web+homepage: https://github.com/okue/haskyapi#readme+bug-reports: https://github.com/okue/haskyapi/issues+author: okue+maintainer: example@example.com+copyright: 2017 okue+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ README.md++source-repository head+ type: git+ location: https://github.com/okue/haskyapi++library+ hs-source-dirs:+ src+ build-depends:+ aeson+ , base >=4.7 && <5+ , blaze-html+ , bytestring+ , containers+ , directory+ , http-conduit+ , markdown+ , mtl+ , network+ , parsec+ , persistent+ , persistent-sqlite+ , persistent-template+ , split+ , tagsoup+ , text+ , time+ , utf8-string+ exposed-modules:+ Web.Haskyapi+ Web.Haskyapi.Config.Config+ Web.Haskyapi.Console.Cli+ Web.Haskyapi.Header+ Web.Haskyapi.Tool+ other-modules:+ Web.Haskyapi.Config.Defaults+ Web.Haskyapi.Config.Parser+ default-language: Haskell2010++executable haskyapi+ main-is: Main.hs+ hs-source-dirs:+ app+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ aeson+ , base >=4.7 && <5+ , blaze-html+ , bytestring+ , containers+ , directory+ , haskyapi+ , http-conduit+ , markdown+ , mtl+ , network+ , parsec+ , persistent+ , persistent-sqlite+ , persistent-template+ , split+ , tagsoup+ , text+ , time+ , utf8-string+ other-modules:+ Api.Hapi+ Model+ ModelDef+ default-language: Haskell2010++test-suite test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs:+ test+ app+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ aeson+ , base >=4.7 && <5+ , blaze-html+ , bytestring+ , containers+ , directory+ , haskyapi+ , http-conduit+ , markdown+ , mtl+ , network+ , parsec+ , persistent+ , persistent-sqlite+ , persistent-template+ , split+ , tagsoup+ , text+ , time+ , utf8-string+ other-modules:+ Api.Hapi+ Model+ ModelDef+ default-language: Haskell2010
+ src/Web/Haskyapi.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE LambdaCase #-}+module Web.Haskyapi (+ runServer,+ Port+) where++-- http://hackage.haskell.org/package/network-2.4.0.1/docs/Network-Socket.html +-- http://qiita.com/asukamirai/items/522cc3c07d7d9ad21dfa ++import Network.Socket hiding (send, sendTo, recv, recvFrom)+import Network.Socket.ByteString+import qualified Codec.Binary.UTF8.String as B8+import qualified Data.ByteString.Char8 as C+import qualified Data.List.Split as L+import qualified Data.List as L+import qualified Text.Markdown as Md+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.IO as T+import Data.Char (ord)+import Data.Maybe (fromMaybe)+import Text.Blaze.Html.Renderer.Text (renderHtml)+import Data.Time.Clock (getCurrentTime)+import Data.Time.LocalTime (utcToLocalTime, TimeZone(..))+import Control.Concurrent+import Control.Exception+import Control.Monad++import Debug.Trace (trace)++import qualified Web.Haskyapi.Tool as Tool+import Web.Haskyapi.Header++type Port = String++jst :: TimeZone+jst = TimeZone {+ timeZoneMinutes = 540,+ timeZoneSummerOnly = False,+ timeZoneName = "JST"+ }++runServer :: (Port, FilePath, String, SubDomain, [Api]) -> IO ()+runServer (port,root,ip,subdomain,routing) = do+ soc <- serveSocket ip port+ listen soc 10+ startSocket soc (root,subdomain,routing) `finally` close soc++serveSocket :: String -> Port -> IO Socket+serveSocket ip port = do+ soc <- socket AF_INET Stream defaultProtocol+ addr <- inet_addr ip+ setSocketOption soc ReusePort (read port)+ bind soc (SockAddrInet (read port) addr)+ return soc++startSocket :: Socket -> (FilePath,SubDomain,[Api]) -> IO ()+startSocket soc cf = forever $ do+ (conn, addr) <- accept soc+ forkIO $ doResponse conn cf++data Status = OK+ | NotFound+ | Moved++instance Show Status where+ show OK = "200 OK"+ show NotFound = "404 Not Found"+ show Moved = "301 Moved Permanently"++htmlhead :: String+htmlhead = unlines [+ "<head>",+ "<link rel=\"stylesheet\" href=\"https://raw.githubusercontent.com/sindresorhus/github-markdown-css/gh-pages/github-markdown.css\" type=\"text/css\"/>\n<meta name=\"viewport\" content=\"width=device-width, initial-scale=1, minimum-scale=1, maximum-scale=1, user-scalable=no\">",+ "<link rel=\"stylesheet\" href=\"/css/markdown.css\" type=\"text/css\"/>\n<meta name=\"viewport\" content=\"width=device-width, initial-scale=1, minimum-scale=1, maximum-scale=1, user-scalable=no\">",+ "</head>"+ ]++doResponse :: Socket -> (FilePath,SubDomain,[Api]) -> IO ()+doResponse conn (root',subdomain,routing) = do+ (str, _) <- recvFrom conn 2048+ let bdy = last . L.splitOn "\r\n" $ C.unpack str+ hdr = parse . L.splitOn "\r\n" $ C.unpack str+ RqLine mtd trg qry = hRqLine hdr+ host = fromMaybe "" $ hHost hdr+ ct = case Tool.getFileExt trg of+ Nothing -> Chtml+ Just ex -> toCType ex+ root = root' ++ dlookup (cutSubdomain host) subdomain+ -- print $ unwords $ map (show . ord) $ C.unpack str+ putStr "["+ putStr . show =<< utcToLocalTime jst <$> getCurrentTime+ putStr "] "+ print hdr+ case (mtd, trg) of+ (GET, "/") ->+ (sender OK conn Chtml =<< C.readFile (root ++ "/index.html"))+ `catch` \(SomeException e) -> do+ print e+ sender NotFound conn ct $ C.pack "404 Not Found"+ (mtd, '/':'a':'p':'i':endpoint) ->+ apisender OK conn routing endpoint qry mtd bdy+ (GET, path) ->+ case (ct, complement path) of+ (Cmarkdown, Just cpath) -> do+ tmp <- T.readFile $ root ++ cpath+ let mdfile = renderHtml $ Md.markdown Md.def tmp+ aux b = htmlhead ++ "<body>" ++ b ++ "</body>"+ sender OK conn ct $ C.pack . B8.encodeString . aux . T.unpack $ mdfile+ (_, Just cpath) -> sender OK conn ct =<< C.readFile (root ++ cpath)+ (_, Nothing) -> redirect conn path+ `catch`+ \(SomeException e) -> do+ print e+ sender NotFound conn ct $ C.pack "404 Not Found"+ (POST, _) ->+ sender OK conn ct $ C.pack "Please POST request to /api"+ _ ->+ sender NotFound conn Chtml $ C.pack "404 Not Found"++----------------------------------+-- hoge/ -> hoge/index.html+-- hoge.html -> hoge.html+-- hoge -> Nothing+----------------------------------+complement :: String -> Maybe String+complement path =+ let bn = Tool.basename path in+ case bn of+ -- path ends with '/'+ "" -> Just $ path ++ "index.html"+ _+ -- basename has a file extension such as ".html"+ | length (L.splitOn "." bn) > 1 -> Just path+ | otherwise -> Nothing++redirect :: Socket -> String -> IO ()+redirect conn path = do+ sendHeader conn Moved Chtml 0+ print path+ sendMany conn $ map C.pack [ "Location: ", path, "/\r\n\r\n" ]+ `catch`+ (\(SomeException e) -> print e)+ `finally`+ close conn -- >> putStrLn ("close conn " ++ show conn)++sender :: Status -> Socket -> ContentType -> C.ByteString -> IO ()+sender st conn ct msg = do+ sendHeader conn st ct (C.length msg)+ sendMany conn [ C.pack "\r\n", msg, C.pack "\r\n" ]+ `catch`+ (\(SomeException e) -> print e)+ `finally`+ close conn -- >> putStrLn ("close conn " ++ show conn)++apisender :: Status -> Socket -> [Api] -> Endpoint -> Query -> Method -> Body -> IO ()+apisender st conn routing endpoint qry mtd bdy = do+ let h = "Access-Control-Allow-Origin: *\r\n\r\n"+ c <- case rlookup (mtd, endpoint) routing of+ Nothing -> do+ sendHeader conn st Cplain 0+ return "There is no valid api."+ Just (_,_,func,ct) -> do+ sendHeader conn st ct 0+ fmap B8.encodeString (func qry bdy)+ sendMany conn $ map C.pack [ h, c, "\r\n" ]+ `catch`+ (\(SomeException e) -> print e)+ `finally`+ close conn -- >> putStrLn ("close conn " ++ show conn)++sendHeader :: Socket -> Status -> ContentType -> Int -> IO Int+sendHeader conn st ct cl = do+ send conn $ C.pack $ "HTTP/1.1 " ++ show st ++ "\r\n"+ case filter (== ct) [Cjpeg, Cpng, Cpdf] of+ [] ->+ sendMany conn $ map C.pack [ "Content-Type: ", show ct, "; charset=utf-8\r\n" ]+ _ ->+ sendMany conn $ map C.pack [+ "Accept-Ranges:bytes\r\n",+ "Content-Type: ", show ct, "\r\n" ]+ case cl of+ 0 -> return ()+ _ -> sendMany conn $ map C.pack [ "Content-Length: ", show cl, "\r\n" ]+ send conn $ C.pack "Server: Haskyapi\r\n"+++cutSubdomain :: String -> String+cutSubdomain = head . L.splitOn "."++dlookup :: String -> SubDomain -> String+dlookup d subdomain =+ case lookup d subdomain of+ Just x -> x+ Nothing -> ""++rlookup :: (Method, Endpoint) -> [Api] -> Maybe Api+rlookup _ [] = Nothing+rlookup me@(mtd, ep) ((x@(mtd',ep',_,_)):xs)+ | mtd == mtd' && ep == ep' = Just x+ | otherwise = rlookup me xs+
+ src/Web/Haskyapi/Config/Config.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE MultiWayIf, BangPatterns#-}+{-# LANGUAGE OverloadedStrings, LambdaCase #-}+module Web.Haskyapi.Config.Config (+ domain,+ subdomain,+ db,+ ip,+ port,+) where++import qualified Data.Text as T+import Data.Maybe+import Data.Map ((!))+import Control.Arrow ((&&&))+import Control.Exception++import Web.Haskyapi.Header (Domain, SubDomain)+import Web.Haskyapi.Config.Defaults (defs)+import Web.Haskyapi.Config.Parser+++parsedFile =+ sparser "setting.yml" <$> readFile "setting.yml"+ `catch` \(SomeException e) -> return []++slookup k [] = Nothing+slookup k (x:xs)+ | k == key x = Just x+ | otherwise = slookup k xs++aux def k fun =+ parsedFile >>= \case+ Left x -> return def+ Right x -> return . maybe def fun $ slookup k x++subdomain :: IO SubDomain+subdomain = map (key &&& aval) <$> aux [] "subdomain" bval++domain :: IO Domain+domain = aux (defs ! "domain") "domain" aval++port = aux (defs ! "port") "port" aval+ip = aux (defs ! "ip") "ip" aval+db = T.pack <$> aux (defs ! "db") "db" aval++main = do+ print =<< domain+ print =<< ip+ print =<< db+ print =<< subdomain
+ src/Web/Haskyapi/Config/Defaults.hs view
@@ -0,0 +1,12 @@+module Web.Haskyapi.Config.Defaults (+ defs+) where++import Data.Map++defs = fromList [+ ("domain", "localhost")+ , ("port", "8080")+ , ("ip", "0.0.0.0")+ , ("db", "app.db")+ ]
+ src/Web/Haskyapi/Config/Parser.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE RecordWildCards, BangPatterns #-}+module Web.Haskyapi.Config.Parser (+ sparser,+ A (..),+) where+import Text.Parsec+import Control.Applicative ((<$>), (<*>))++data A = A { key :: String, aval :: String }+ | B { key :: String, bval :: [A] }+ deriving (Show)+++sptab = many (oneOf " \t")+nt = oneOf "\n" *> (oneOf "\t" <|> char ' ' *> char ' ')++sparser :: String -> String -> Either ParseError [A]+sparser name str = parse (_sparser []) name str+ where+ _sparser l = do+ sharp+ many (oneOf "\n")+ a <- colon+ many (oneOf "\n")+ sharp+ try (eof *> return (a:l)) <|> _sparser (a:l)++colon = do+ x <- many alphaNum+ sptab *> char ':' *> sptab+ try (B x <$> (nt *> hyphens)) <|> (A x <$> many1 (alphaNum <|> oneOf "."))++arrow = do+ x <- many alphaNum+ sptab *> string "->" *> sptab+ A x <$> many1 (alphaNum <|> oneOf "./")++hyphens = _hyphens []+ where+ _hyphens l = do+ a <- hyphen+ try (sptab *> nt *> _hyphens (a:l)) <|> return (a:l)++hyphen = do+ char '-' *> sptab+ a <- arrow+ return a++sharp =+ try+ (oneOf "#" *> many (noneOf "\n") *> many (oneOf "\n") *> sharp)+ <|>+ return ()++main = do+ f <- readFile "./setting.yml"+ putStrLn f+ print $ sparser "setting.yml" f+ -- parseTest sparser "x: y\nip : 0.0.0.0\n\nsub :\n\t- hoge -> foo\n\t- foo -> okok"+ -- parseTest sharp "## comment out\n# comment\t is\n##########\n"
+ src/Web/Haskyapi/Console/Cli.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiWayIf, RankNTypes, BangPatterns#-}+module Web.Haskyapi.Console.Cli (+ haskyapi,+ haskyapiM,+ argparse,+ Option(..),+ Mode(..),+) where++import System.Directory (getCurrentDirectory, getDirectoryContents)+import System.Environment (getArgs)+import System.Exit+import Control.Monad.State+import Control.Applicative ((<$>))+import qualified Data.List.Split as L+import qualified Data.List as L+import Data.Maybe (fromMaybe)+import Data.Map ((!))++import qualified Web.Haskyapi.Config.Config as Config+import Web.Haskyapi.Config.Defaults (defs)+import Web.Haskyapi (runServer, Port)+import Web.Haskyapi.Header (Api)+++--------------------------------------------------------+-- command option+--------------------------------------------------------+-- haskyapi --help+-- haskyapi --version+-- haskyapi migrate+-- haskyapi migrate --help+-- haskyapi runserver --help+-- haskyapi runserver --root ... --port ... --ip ...+--------------------------------------------------------++data Mode a = Runserver a+ | Migrate a+ | Message String+ | Error String+ deriving (Show)++mode2str :: Mode a -> String+mode2str (Runserver _) = "haskyapi runserver\n"+mode2str (Migrate _) = "haskyapi migrate\n"+mode2str (Message _) = "message"+mode2str (Error _) = "error"++instance Functor Mode where+ fmap f (Runserver x) = Runserver (f x)+ fmap f (Migrate x) = Migrate (f x)+ fmap f (Message x) = Message x+ fmap _ (Error x) = Error x++data Arg = Arg {+ key :: [String],+ def :: String,+ name :: String,+ description :: String+ }++type A = (String, String)++data Option = OptRunserver {+ oport :: String,+ oroot :: String,+ oip :: String+ }+ | OptMigrate+ deriving (Show)++argConfMigrate :: [Arg]+argConfMigrate = [+ Arg ["-h", "--help"] "...." "help" "Help"+ ]++argConfRunserver :: [Arg]+argConfRunserver = [+ Arg ["-p", "--port"] (defs ! "port") "port" "Port number"+ ,Arg ["-i", "--ip" ] (defs ! "ip") "ip" "IP"+ ,Arg ["-r", "--root"] "html" "root" "Root directory"+ ,Arg ["-h", "--help"] "...." "help" "Help"+ ]++verMessage = "haskyapi version 0.0.0.1"++argparse :: [String] -> Mode Option+argparse args =+ case checkmode args of+ Error x -> Error x+ Message x -> Message x+ Runserver xs -> argparseMain argConfRunserver xs Runserver+ Migrate xs -> argparseMain argConfMigrate xs Migrate+ where+ checkmode :: [String] -> Mode [String]+ checkmode ("runserver":xs) = Runserver xs+ checkmode ("migrate" :xs) = Migrate xs+ checkmode ("--version":_) = Message verMessage+ checkmode ("-v":_) = Message verMessage+ checkmode ("--help":_) = Message mkHelpAll+ checkmode ("-h":_) = Message mkHelpAll+ checkmode _ = Error "invalid mode!!"+ mkHelpAll :: String+ mkHelpAll = mkHelp [("haskyapi migrate\n", argConfMigrate), ("haskyapi runserver\n", argConfRunserver)]+ mkHelp lst = concat $ foldl (\l (x,y) -> [x, aux y] ++ l ) [] lst+ where+ aux = unlines . map aux'+ -- Arg's Example => Arg ["-p", "--port"] "8080" "port" "Port number"+ aux' (Arg forms defa nm desc) = L.intercalate "\t" [ "\t" ++ eqleng 6 nm,+ eqleng 11 (unwords forms),+ "defaulut = " ++ eqleng 8 defa,+ desc+ ]+ eqleng th xs =+ let !l = length xs in+ if | length xs <= th -> xs ++ replicate (th-l) ' '+ | otherwise -> xs+ argparseMain :: [Arg] -> [String] -> ([A] -> Mode [A]) -> Mode Option+ argparseMain argconf xs mode = a2optMain $ execState (argparse' xs) (mode [])+ where+ argparse' :: [String] -> State (Mode [A]) ()+ argparse' [] = return ()+ argparse' ("-h":_) = modify $ \x -> Message $ mkHelp [(mode2str (mode []), argconf)]+ argparse' ("--help":_) = modify $ \x -> Message $ mkHelp [(mode2str (mode []), argconf)]+ argparse' [x] = modify $ \_ -> Error ("error near " ++ x)+ argparse' (ag:x:xs) =+ case filter (elem ag . key) argconf of+ [a] -> modify (fmap ((name a, x):)) >> argparse' xs+ _ -> modify $ \x -> Error ("invalid argument " ++ ag)+ a2optMain :: Mode [A] -> Mode Option+ a2optMain (Runserver as) = Runserver (a2opt as)+ a2optMain (Migrate as) = Migrate OptMigrate+ a2optMain (Message x) = Message x+ a2optMain (Error x) = Error x+ a2opt :: [A] -> Option+ a2opt as = execState (aux argconf) (OptRunserver "" "" "")+ where+ aux :: [Arg] -> State Option ()+ aux [] = return ()+ aux (acf:acfs) =+ let nm = name acf+ a = fromMaybe (def acf) $ lookup (name acf) as in+ if | nm == "port" -> modify (\x -> x { oport = a }) >> aux acfs+ | nm == "root" -> modify (\x -> x { oroot = a }) >> aux acfs+ | nm == "ip" -> modify (\x -> x { oip = a }) >> aux acfs+ | otherwise -> aux acfs+++-- Main command which users' applications call+haskyapi :: [Api] -> IO ()+haskyapi routing = haskyapiM routing (return ())++haskyapiM :: [Api] -> IO () -> IO ()+haskyapiM routing migrate = do+ args <- getArgs+ case argparse args of+ Error x ->+ putStrLn x+ Message x ->+ putStrLn x+ Runserver opt ->+ mainProc opt+ Migrate opt ->+ migrate+ where+ mainProc :: Option -> IO ()+ mainProc !opt = do+ -- Config.hoge has a default value, and arguments.hoge also has the same default value.+ -- Default values are defined in '../Config/Defaults.hs'+ cpo <- Config.port+ cip <- Config.ip+ csd <- Config.subdomain+ let+ !root = oroot opt+ !_ip = oip opt+ !_po = oport opt+ !ip = if _ip == (defs ! "ip") then cip else _ip+ !port = if _po == (defs ! "port") then cpo else _po+ !url = "http://" ++ ip ++ ":" ++ port ++ "/"+ putStrLn $ "root: " ++ root+ putStrLn $ "listen on " ++ port+ putStrLn url+ mapM_ (putStrLn . \h -> url ++ h) =<< getfiles root+ runServer (port, root, ip, csd, routing)+ where+ getfiles :: FilePath -> IO [FilePath]+ getfiles root =+ filter aux <$> getDirectoryContents root+ where+ aux ('.':_) = False+ aux _ = True+++main :: IO ()+main = do+ print $ argparse ["runserver", "--root", "html"]+ print $ argparse ["migrate", "--help"]+ let Message a = argparse ["runserver", "--help"]+ putStrLn a+ print $ argparse ["migrate"]+ print $ argparse ["-v"]
+ src/Web/Haskyapi/Header.hs view
@@ -0,0 +1,200 @@+module Web.Haskyapi.Header (+ parse,+ RqLine(..),+ Header(..),+ pprint,+ Method(..),+ Query,+ Body,+ Endpoint,+ Api,+ ApiFunc,+ ContentType(..),+ toCType,+ Domain,+ SubDomain,+) where++import qualified Data.ByteString.Char8 as C+import qualified Data.List.Split as S+import qualified Data.List as L+import Data.List.Split (splitOn)+import Data.Maybe+import Control.Monad++import Debug.Trace (trace)++type Domain = String+type SubDomain = [(String, String)]+type Api = (Method, Endpoint, ApiFunc, ContentType)+type ApiFunc = Query -> Body -> IO String++type Body = String+type Query = [(String, String)]+type Endpoint = String++data Method = GET + | POST+ | PUT+ | DELETE+ | PATCH+ | Other+ deriving (Show, Eq)++toMethod :: String -> Method+toMethod "GET" = GET+toMethod "POST" = POST+toMethod "PUT" = PUT+toMethod "DELETE" = DELETE+toMethod "PATCH" = PATCH+toMethod _ = Other++data RqLine = RqLine {+ method :: Method,+ target :: String,+ parameters :: Query+ } deriving (Show, Eq)++data Header = Header {+ hRqLine :: RqLine,+ hHost :: Maybe String,+ hUserAgent :: Maybe String,+ hAccept :: Maybe String,+ hContentLength :: Maybe String,+ hContentType :: Maybe String,+ hReferer :: Maybe String+ } deriving (Eq)++pprint :: Header -> IO ()+pprint hdr = putStr $ L.intercalate "\n" [+ "RequestLine -> " ++ show (hRqLine hdr),+ "Host -> " ++ maybe "nothing" show (hHost hdr),+ "UserAgent -> " ++ maybe "nothing" show (hUserAgent hdr),+ "Accept -> " ++ maybe "nothing" show (hAccept hdr),+ "ContentLength -> " ++ maybe "nothing" show (hContentLength hdr),+ "ContentType -> " ++ maybe "nothing" show (hContentType hdr),+ "Referer -> " ++ maybe "nothing" show (hReferer hdr)+ ]+++instance Show Header where+ show hdr = unwords [+ "[RequestLine: " ++ rqLine2Str (hRqLine hdr) ++ "]",+ "[Host: " ++ maybe "nothing" show (hHost hdr) ++ "]",+ "[UserAgent: " ++ maybe "nothing" show (hUserAgent hdr) ++ "]",+ "[Accept: " ++ maybe "nothing" show (hAccept hdr) ++ "]",+ "[ContentLength: " ++ maybe "nothing" show (hContentLength hdr) ++ "]",+ "[ContentType: " ++ maybe "nothing" show (hContentType hdr) ++ "]",+ "[Referer: " ++ maybe "nothing" show (hReferer hdr) ++ "]"+ ]+ where+ rqLine2Str (RqLine m s q) = unwords [ show m, s, show q ]++unitheader :: Header+unitheader = Header {+ hRqLine = RqLine GET "/" [],+ hHost = Nothing,+ hUserAgent = Nothing,+ hAccept = Nothing,+ hContentLength = Nothing,+ hContentType = Nothing,+ hReferer = Nothing+ }++mkqry :: String -> (Endpoint, Query)+mkqry tmp =+ let ep:qry' = S.splitOneOf "?&" tmp+ qry = map (qsplit "") qry'+ in (ep, qry)++qsplit :: String -> String -> (String, String)+qsplit key "" = ("", "")+qsplit key (c:cs)+ | c == '=' = (key, cs)+ | otherwise = qsplit (key++[c]) cs++-------------------------------------------------------------+-- Example+-------------------------------------------------------------+-- GET / HTTP/1.1+-- Host: hoge.com+-- Connection: keep-alive+-- Pragma: no-cache+-- Cache-Control: no-cache+-- Upgrade-Insecure-Requests: 1+-- User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10_11_6) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/61.0.3163.100 Safari/537.36+-- Accept: text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,image/apng,*/*;q=0.8+-- Accept-Encoding: gzip, deflate+-- Accept-Language: ja,en-US;q=0.8,en;q=0.6,zh-CN;q=0.4,zh;q=0.2+-- Cookie: _ga=GA1.2.1220732232.1506737218+-------------------------------------------------------------++parseRqLine :: String -> Header -> Header+parseRqLine str hdr =+ -- Assume: Request Line is always in the valid form.+ -- GET /hoge/index.html HTTP/1.1+ let mtd':tmp:_ = words str+ (ep,qry) = mkqry tmp+ mtd = RqLine {method=toMethod mtd', target=ep, parameters=qry}+ in hdr { hRqLine = mtd }++parse :: [String] -> Header+parse [] = unitheader+parse (x:xs) =+ -- In HTTP protocol, the first line must be Request Line+ let firstheader = parseRqLine x unitheader in+ foldl str2h firstheader xs+ where+ str2h hdr "" = hdr+ str2h hdr str =+ let key:rest = words str in+ case key of+ "Host:" -> hdr { hHost = Just (head rest) }+ "User-Agent:" -> hdr { hUserAgent = Just (head rest) }+ "Accept:" -> hdr { hAccept = Just (head rest) }+ "Content-Length:" -> hdr { hContentLength = Just (head rest) }+ "Content-Type:" -> hdr { hContentType = Just (head rest) }+ "Referer:" -> hdr { hReferer = Just (head rest) }+ _ -> hdr++data ContentType = Chtml+ | Ccss+ | Cjs+ | Cjson+ | Cplain+ | Cjpeg+ | Cpng+ | Cgif+ | Cpdf+ | Cmarkdown+ deriving (Eq)++instance Show ContentType where+ show Cmarkdown = show Chtml+ show Chtml = "text/html"+ show Ccss = "text/css"+ show Cjs = "text/javascript"+ show Cplain = "text/plain"+ show Cjpeg = "image/jpeg"+ show Cpng = "image/png"+ show Cgif = "image/gif"+ show Cpdf = "application/pdf"+ show Cjson = "application/json"+ -- show _ = "text/plain"++toCType :: String -> ContentType+toCType "html" = Chtml+toCType "htm" = Chtml+toCType "md" = Cmarkdown+toCType "css" = Ccss+toCType "js" = Cjs+toCType "plain" = Cplain+toCType "jpeg" = Cjpeg+toCType "png" = Cpng+toCType "gif" = Cgif+toCType "pdf" = Cpdf+toCType "txt" = Cplain+toCType "text" = Cplain+toCType "json" = Cjson+toCType _ = Cplain+
+ src/Web/Haskyapi/Tool.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiWayIf #-}+module Web.Haskyapi.Tool (+ getFileExt,+ basename,+) where++import qualified Data.List.Split as L+import qualified Data.List as L++getFileExt :: String -> Maybe String+getFileExt path =+ let ex = last . L.splitOn "." $ path in+ if | ex == path -> Nothing+ | otherwise -> Just ex++basename :: String -> String+basename = last . L.splitOn "/"
+ test/Spec.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiWayIf #-}++main :: IO ()+main = do+ putStrLn "Test of Spec.hs"+ putStrLn "No Test."