diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,58 @@
+
+
+[](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)
+
diff --git a/app/Api/Hapi.hs b/app/Api/Hapi.hs
new file mode 100644
--- /dev/null
+++ b/app/Api/Hapi.hs
@@ -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
+
diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
--- /dev/null
+++ b/app/Main.hs
@@ -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
diff --git a/app/Model.hs b/app/Model.hs
new file mode 100644
--- /dev/null
+++ b/app/Model.hs
@@ -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"
diff --git a/app/ModelDef.hs b/app/ModelDef.hs
new file mode 100644
--- /dev/null
+++ b/app/ModelDef.hs
@@ -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"
diff --git a/haskyapi.cabal b/haskyapi.cabal
new file mode 100644
--- /dev/null
+++ b/haskyapi.cabal
@@ -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
+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
diff --git a/src/Web/Haskyapi.hs b/src/Web/Haskyapi.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Haskyapi.hs
@@ -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 [
+ "",
+ "\n",
+ "\n",
+ ""
+ ]
+
+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 ++ "" ++ b ++ ""
+ 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
+
diff --git a/src/Web/Haskyapi/Config/Config.hs b/src/Web/Haskyapi/Config/Config.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Haskyapi/Config/Config.hs
@@ -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
diff --git a/src/Web/Haskyapi/Config/Defaults.hs b/src/Web/Haskyapi/Config/Defaults.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Haskyapi/Config/Defaults.hs
@@ -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")
+ ]
diff --git a/src/Web/Haskyapi/Config/Parser.hs b/src/Web/Haskyapi/Config/Parser.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Haskyapi/Config/Parser.hs
@@ -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"
diff --git a/src/Web/Haskyapi/Console/Cli.hs b/src/Web/Haskyapi/Console/Cli.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Haskyapi/Console/Cli.hs
@@ -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"]
diff --git a/src/Web/Haskyapi/Header.hs b/src/Web/Haskyapi/Header.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Haskyapi/Header.hs
@@ -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
+
diff --git a/src/Web/Haskyapi/Tool.hs b/src/Web/Haskyapi/Tool.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Haskyapi/Tool.hs
@@ -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 "/"
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE MultiWayIf #-}
+
+main :: IO ()
+main = do
+ putStrLn "Test of Spec.hs"
+ putStrLn "No Test."