commit b71fabfa4b5b5cf1a5b0d804c1555f5b5af6a4ff
Author: krasjet
Date: 2020-03-17 03:49Z
init, take 2
Diffstat:
22 files changed, 684 insertions(+), 0 deletions(-)
diff --git a/.gitignore b/.gitignore
@@ -0,0 +1,8 @@
+.stack-work/
+db/
+docs/
+.env
+static
+design
+stack.yaml.lock
+
diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml
@@ -0,0 +1,24 @@
+steps:
+ - simple_align:
+ cases: true
+ top_level_patterns: true
+ records: true
+ - imports:
+ align: group
+ list_align: after_alias
+ pad_module_names: true
+ long_list_align: inline
+ empty_list_align: right_after
+ list_padding: module_name
+ separate_lists: true
+ space_surround: false
+ - language_pragmas:
+ style: vertical
+ align: true
+ remove_redundant: true
+ language_prefix: LANGUAGE
+ - trailing_whitespace: {}
+
+columns: 80
+newline: lf
+cabal: true
diff --git a/Makefile b/Makefile
@@ -0,0 +1,29 @@
+.PHONY: run run-kamome run-karasu build-karasu build-kamome debug ghci clean
+
+run: build-kamome run-karasu
+
+run-kamome:
+ @ln -snf kamome/dist static
+ @cd kamome && yarn start
+
+run-karasu:
+ @stack run
+
+build-karasu:
+ @stack build
+
+build-kamome:
+ @cd kamome && yarn build
+ @ln -snf kamome/dist static
+
+debug:
+ @stack run karasu-debug
+
+ghci:
+ @stack ghci
+
+clean:
+ rm -rf ./db
+ rm -rf ./docs
+ rm -rf ./kamome/dist/*
+
diff --git a/README.md b/README.md
@@ -0,0 +1,3 @@
+# karasu
+
+A work in progress.
diff --git a/Setup.hs b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/app/Main.hs b/app/Main.hs
@@ -0,0 +1,6 @@
+module Main where
+
+import Karasu
+
+main :: IO ()
+main = runKarasu
diff --git a/kamome b/kamome
@@ -0,0 +1 @@
+Subproject commit 238d3ec812b60c000c7f4b7d00e0e928c5be5264
diff --git a/karasu.cabal b/karasu.cabal
@@ -0,0 +1,92 @@
+cabal-version: >=2.0
+
+-- This file has been generated from package.yaml by hpack version 0.31.2.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: 1c6146379423834387b558bd03ebccfc375815488f25cfa367445b5a4c94e74c
+
+name: karasu
+version: 0.1.0.0
+description: A work in progress.
+category: Web
+author: Krasjet
+maintainer: Krasjet
+copyright: Copyright (c) 2020 Krasjet
+license: MIT
+build-type: Simple
+extra-source-files:
+ README.md
+
+library
+ exposed-modules:
+ Karasu
+ Karasu.Api
+ Karasu.Database
+ Karasu.Environment
+ Karasu.Handler
+ Karasu.Handlers.ApiCreateDoc
+ Karasu.Handlers.ApiEditDoc
+ Karasu.Handlers.ApiGetDoc
+ Karasu.Handlers.ApiPreviewDoc
+ Karasu.Handlers.Static
+ Karasu.Models
+ Karasu.Server
+ other-modules:
+ Paths_karasu
+ hs-source-dirs:
+ src
+ ghc-options: -Wall -Werror
+ build-depends:
+ aeson
+ , base >=4.7 && <5
+ , blaze-html
+ , bytestring
+ , directory
+ , dotenv
+ , filepath
+ , monad-logger
+ , mtl
+ , pandoc >=2.7 && <2.10
+ , persistent-sqlite
+ , persistent-template
+ , servant
+ , servant-blaze
+ , servant-server
+ , text
+ , transformers
+ , wai
+ , wai-extra
+ , warp
+ default-language: Haskell2010
+
+executable karasu
+ main-is: Main.hs
+ other-modules:
+ Paths_karasu
+ hs-source-dirs:
+ app
+ ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N
+ build-depends:
+ aeson
+ , base >=4.7 && <5
+ , blaze-html
+ , bytestring
+ , directory
+ , dotenv
+ , filepath
+ , karasu
+ , monad-logger
+ , mtl
+ , pandoc >=2.7 && <2.10
+ , persistent-sqlite
+ , persistent-template
+ , servant
+ , servant-blaze
+ , servant-server
+ , text
+ , transformers
+ , wai
+ , wai-extra
+ , warp
+ default-language: Haskell2010
diff --git a/package.yaml b/package.yaml
@@ -0,0 +1,56 @@
+name: karasu
+version: 0.1.0.0
+license: MIT
+author: "Krasjet"
+maintainer: "Krasjet"
+copyright: "Copyright (c) 2020 Krasjet"
+
+extra-source-files:
+- README.md
+
+category: Web
+
+description: "A work in progress."
+
+dependencies:
+- base >= 4.7 && < 5
+- aeson
+- blaze-html
+- bytestring
+- directory
+- dotenv
+- filepath
+- monad-logger
+- mtl
+- pandoc >= 2.7 && < 2.10
+- persistent-template
+- persistent-sqlite
+- servant
+- servant-server
+- servant-blaze
+- text
+- transformers
+- wai
+- wai-extra
+- warp
+
+ghc-options:
+- -Wall
+- -Werror
+
+library:
+ source-dirs: src
+
+executables:
+ karasu:
+ main: Main.hs
+ source-dirs: app
+ ghc-options:
+ - -threaded
+ - -rtsopts
+ - -with-rtsopts=-N
+ dependencies:
+ - karasu
+
+verbatim:
+ cabal-version: ">=2.0"
diff --git a/src/Karasu.hs b/src/Karasu.hs
@@ -0,0 +1,54 @@
+module Karasu (runKarasu) where
+
+import Karasu.Api
+import Karasu.Database
+import Karasu.Environment
+import Karasu.Server
+
+import qualified Data.Text as T
+
+import Configuration.Dotenv (defaultConfig, loadFile)
+import Control.Monad (void)
+import Network.Wai.Handler.Warp
+import Network.Wai.Middleware.RequestLogger (logStdout)
+import Servant
+import System.FilePath.Posix ((</>))
+
+-- * application
+app :: KarasuEnv -> Application
+app env = serve karasuApi $ karasuServer env
+
+-- * server
+karasuSettings :: KarasuEnv -> Settings
+karasuSettings env =
+ let port = envPort env in
+ setPort port $
+ setBeforeMainLoop (putStrLn $ "Karasu listening on port " ++ show port)
+ defaultSettings
+
+-- | The actual main function
+runKarasu :: IO ()
+runKarasu = do
+ -- load environments
+ env <- loadEnv
+ let settings = karasuSettings env
+ runSettings settings $ logStdout $ app env
+ -- ^ middleware for logging
+
+-- | Load runtime environments
+loadEnv :: IO KarasuEnv
+loadEnv = do
+ void $ loadFile defaultConfig
+ debug <- lookupEnvVarParse "KARASU_DEBUG" False
+ port <- lookupEnvVarParse "KARASU_PORT" 8080
+ dbFile <- lookupEnvVar "KARASU_DB" $ "db" </> "karasu.db"
+ masterPass <- lookupEnvVar "KARASU_MASTERPASS" "karasu"
+ docDir <- lookupEnvVar "KARASU_DOCDIR" "docs"
+ pool <- mkPool dbFile debug
+ return KarasuEnv
+ { envDebug = debug
+ , envPort = port
+ , envPool = pool
+ , envMaster = T.pack masterPass
+ , envDocDir = docDir
+ }
diff --git a/src/Karasu/Api.hs b/src/Karasu/Api.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- | A summary of all the API definitions
+module Karasu.Api (KarasuApi, ReqApi, karasuApi, reqApi) where
+
+import Karasu.Handlers.ApiCreateDoc
+import Karasu.Handlers.ApiEditDoc
+import Karasu.Handlers.ApiGetDoc
+import Karasu.Handlers.ApiPreviewDoc
+import Karasu.Handlers.Static
+
+import Servant
+
+-- API for requests
+type ReqApi = CreateDocApi :<|> EditDocApi :<|> GetDocApi :<|> PreviewDocApi
+-- combined APIs for the app
+type KarasuApi = ReqApi :<|> StaticFiles
+
+reqApi :: Proxy ReqApi
+reqApi = Proxy
+
+karasuApi :: Proxy KarasuApi
+karasuApi = Proxy
diff --git a/src/Karasu/Database.hs b/src/Karasu/Database.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+-- | Functions for querying database
+module Karasu.Database (doMigrations, runDb, mkPool) where
+
+import Karasu.Environment
+import Karasu.Models
+
+import qualified Data.Text as T
+
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Logger (runNoLoggingT, runStdoutLoggingT)
+import Control.Monad.Reader (MonadReader, asks)
+import Database.Persist.Sqlite
+import System.Directory (createDirectoryIfMissing)
+import System.FilePath (takeDirectory)
+
+doMigrations :: SqlPersistT IO ()
+doMigrations = runMigration migrateAll
+
+runDb :: (MonadReader KarasuEnv m, MonadIO m) => SqlPersistT IO b -> m b
+runDb query = do
+ pool <- asks envPool
+ liftIO $ runSqlPool query pool
+
+-- | Create databse pool
+mkPool :: FilePath -> Bool -> IO ConnectionPool
+mkPool dbFile debug = do
+ createDirectoryIfMissing True $ takeDirectory dbFile
+ pool <- if debug
+ then runStdoutLoggingT $ createSqlitePool (T.pack dbFile) 5
+ else runNoLoggingT $ createSqlitePool (T.pack dbFile) 5
+ runSqlPool doMigrations pool
+ return pool
diff --git a/src/Karasu/Environment.hs b/src/Karasu/Environment.hs
@@ -0,0 +1,41 @@
+-- |
+-- A few ultility functions to deal with runtime environments, i.e. a global
+-- state shared by all handlers
+module Karasu.Environment (KarasuEnv(..), lookupEnvVar, lookupEnvVarParse) where
+
+import Karasu.Models (MasterPassword)
+
+import Configuration.Dotenv.Environment (lookupEnv)
+import Data.Maybe (fromMaybe)
+import Database.Persist.Sqlite (ConnectionPool)
+import Network.Wai.Handler.Warp (Port)
+import Text.Read (readMaybe)
+
+-- * Environment variables
+data KarasuEnv
+ = KarasuEnv
+ { envDebug :: Bool -- in debug mode or not
+ , envPool :: ConnectionPool -- connection pool for database
+ , envPort :: Port -- port number of the server
+ , envMaster :: MasterPassword -- master password for creating documents (TODO encryption)
+ , envDocDir :: FilePath -- directory storing markdown files
+ }
+
+-- | Obtain an environment variable and parse with default value
+lookupEnvVarParse
+ :: Read a
+ => String -- ^ the environemnt variable
+ -> a -- ^ the default value
+ -> IO a
+lookupEnvVarParse envVar defVal = do
+ var <- lookupEnv envVar
+ return $ fromMaybe defVal $ var >>= readMaybe
+
+-- | Obtain an environment variable with default value
+lookupEnvVar
+ :: String -- ^ the environemnt variable
+ -> String -- ^ the default value
+ -> IO String
+lookupEnvVar envVar defVal = do
+ var <- lookupEnv envVar
+ return $ fromMaybe defVal var
diff --git a/src/Karasu/Handler.hs b/src/Karasu/Handler.hs
@@ -0,0 +1,15 @@
+-- | Our own custom handler
+module Karasu.Handler (KHandler, nt) where
+
+import Karasu.Environment (KarasuEnv)
+
+import Control.Monad.Trans.Reader (ReaderT, runReaderT)
+import Servant (Handler)
+
+-- | A wrapper for servant Handler
+-- This allows us to compose monads on top of Handler (might expand later)
+type KHandler = ReaderT KarasuEnv Handler
+
+-- the natural transformation KHandler ~> Handler
+nt :: KarasuEnv -> KHandler a -> Handler a
+nt env kHld = runReaderT kHld env
diff --git a/src/Karasu/Handlers/ApiCreateDoc.hs b/src/Karasu/Handlers/ApiCreateDoc.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- | API for creating a document, for private use only
+module Karasu.Handlers.ApiCreateDoc (CreateDocApi, createDoc) where
+
+import Karasu.Database
+import Karasu.Environment
+import Karasu.Handler
+import Karasu.Models
+
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
+
+import Control.Monad (unless, when)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Reader (asks)
+import Data.Aeson
+import Data.Char (isAlphaNum)
+import Data.Maybe (isNothing)
+import Data.Text (Text)
+import Database.Persist.Sqlite
+import GHC.Generics
+import Servant
+import System.Directory (createDirectoryIfMissing)
+import System.FilePath (isPathSeparator, isValid, takeDirectory, (<.>),
+ (</>))
+
+data CreateDocBody = CreateDocBody {
+ docId :: DocId,
+ accessCode :: Maybe AccessCode,
+ masterPass :: MasterPassword
+} deriving (Generic, Show)
+
+instance ToJSON CreateDocBody
+instance FromJSON CreateDocBody
+
+type CreateDocApi = "api"
+ :> "create"
+ :> ReqBody '[JSON] CreateDocBody
+ :> PostCreated '[PlainText] Text
+
+-- | Validate the docId
+-- 1. valid path (empty string should fail here)
+-- 2. not containing any path separator
+-- 3. start with alphanumeric
+validId :: FilePath -> Bool
+validId path = isValid path && not (any isPathSeparator path) && isAlphaNum (head path)
+
+-- | Create new document
+createDoc :: CreateDocBody -> KHandler Text
+createDoc docBody = do
+ correctPass <- asks envMaster
+ -- master password incorrect
+ unless (correctPass == masterPass docBody) $
+ throwError err403 { errBody = "Nope, try again." }
+
+ let dId = docId docBody
+ -- docId not valid filename
+ unless (validId dId) $
+ throwError err400 { errBody = "Can you read the document id?" }
+
+ -- finally insert the document
+ res <- runDb $ insertUnique $ DocInfo (docId docBody) (accessCode docBody) 1
+ -- the docId already exists
+ when (isNothing res) $
+ throwError err409 { errBody = "Something is already there." }
+
+ -- write default markdown file
+ docDir <- asks envDocDir
+ let mdFile = docDir </> dId <.> ".md"
+ liftIO $ createDirectoryIfMissing True $ takeDirectory mdFile
+ liftIO $ TIO.writeFile mdFile $ T.pack $ "# " <> dId <> "\n"
+ return "The doc is up. Hooray!"
diff --git a/src/Karasu/Handlers/ApiEditDoc.hs b/src/Karasu/Handlers/ApiEditDoc.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- | API for creating a document, for private use only
+module Karasu.Handlers.ApiEditDoc (EditDocApi, editDoc) where
+
+import Karasu.Database
+import Karasu.Handler
+import Karasu.Models
+
+import qualified Data.Text.IO as TIO
+
+import Control.Monad.IO.Class (liftIO)
+import Database.Persist.Sqlite
+import Servant
+import Servant.HTML.Blaze
+import System.FilePath ((<.>), (</>))
+import Text.Blaze.Html
+
+type EditDocApi = "edit"
+ :> Capture "docId" DocId
+ :> Get '[HTML] Html
+
+-- | Send the editor page
+editDoc :: DocId -> KHandler Html
+editDoc docId = do
+ res <- runDb $ getBy $ UniqueDocId docId
+ case res of
+ Nothing -> throwError err404 { errBody = "Nothing here." }
+ Just _ -> do
+ -- TODO might want to use responseFile to avoid extra buffering
+ -- https://github.com/haskell-servant/servant/issues/1281
+ html <- liftIO $ TIO.readFile $ "static" </> "editor" <.> "html"
+ return $ preEscapedToMarkup html
diff --git a/src/Karasu/Handlers/ApiGetDoc.hs b/src/Karasu/Handlers/ApiGetDoc.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- | API for retrieving the markdown file
+module Karasu.Handlers.ApiGetDoc (GetDocApi, getDoc) where
+
+import Karasu.Database
+import Karasu.Environment
+import Karasu.Handler
+import Karasu.Models
+
+import qualified Data.Text.IO as TIO
+
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Reader (asks)
+import Data.Aeson
+import Database.Persist.Sqlite
+import GHC.Generics
+import Servant
+import System.FilePath ((<.>), (</>))
+
+data GetDocRes = GetDocRes {
+ markdown :: Markdown,
+ version :: Version
+} deriving (Generic, Show)
+
+instance ToJSON GetDocRes
+instance FromJSON GetDocRes
+
+type GetDocApi = "api"
+ :> "get"
+ :> Capture "docId" DocId
+ :> Get '[JSON] GetDocRes
+
+-- | Return the markdown of the document
+getDoc :: DocId -> KHandler GetDocRes
+getDoc docId = do
+ res <- runDb $ getBy $ UniqueDocId docId
+ case res of
+ Nothing -> throwError err404 { errBody = "Nothing here." }
+ Just (Entity _ doc) -> do
+ let docVer = docInfoVersion doc
+ docDir <- asks envDocDir
+ let mdFile = docDir </> docId <.> ".md"
+ md <- liftIO $ TIO.readFile mdFile
+ return $ GetDocRes md docVer
diff --git a/src/Karasu/Handlers/ApiPreviewDoc.hs b/src/Karasu/Handlers/ApiPreviewDoc.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- | API for markdown -> HTML preview
+module Karasu.Handlers.ApiPreviewDoc (PreviewDocApi, previewDoc) where
+
+import Karasu.Database
+import Karasu.Handler
+import Karasu.Models
+
+import qualified Data.ByteString.Lazy.Char8 as LB8
+
+import Control.Monad (when)
+import Control.Monad.IO.Class (liftIO)
+import Data.Aeson
+import Database.Persist.Sqlite
+import GHC.Generics
+import Servant
+import Servant.HTML.Blaze
+import Text.Blaze.Html
+import Text.Pandoc
+
+data PreviewDocBody = PreviewDocBody {
+ docId :: DocId,
+ markdown :: Markdown,
+ accessCode :: Maybe AccessCode
+} deriving (Generic, Show)
+
+instance ToJSON PreviewDocBody
+instance FromJSON PreviewDocBody
+
+type PreviewDocApi = "api"
+ :> "preview"
+ :> ReqBody '[JSON] PreviewDocBody
+ :> Post '[HTML] Html -- apparently GET request cannot have a body
+
+-- | Process markdown and send preview
+previewDoc :: PreviewDocBody -> KHandler Html
+previewDoc prevBody = do
+ liftIO $ print prevBody
+ let dId = docId prevBody
+ -- check access code
+ res <- runDb $ getBy $ UniqueDocId dId
+ case res of
+ Nothing -> throwError err403 { errBody = "Something wrong with the docId." }
+ Just (Entity _ doc) ->
+ -- yes, no accessCode doesn't mean no protection
+ when (docInfoAccCode doc /= accessCode prevBody) $
+ throwError err403 { errBody = "Nope, try again." }
+ -- now, start rendering the markdown file (TODO lift to a Pandoc package)
+ let md = markdown prevBody
+
+ let out = runPure $ do
+ pandoc <- readMarkdown def md
+ writeHtml5 def pandoc
+ case out of
+ Left err -> throwError err400 { errBody = LB8.pack $ show err }
+ Right html -> return $ preEscapedToMarkup html
diff --git a/src/Karasu/Handlers/Static.hs b/src/Karasu/Handlers/Static.hs
@@ -0,0 +1,6 @@
+-- | The route for serving static files
+module Karasu.Handlers.Static (StaticFiles) where
+
+import Servant
+
+type StaticFiles = Raw
diff --git a/src/Karasu/Models.hs b/src/Karasu/Models.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | Models for database and requests, anything in this module will be exported
+module Karasu.Models where
+
+import Data.Text (Text)
+import Database.Persist.TH
+
+type DocId = FilePath
+type Version = Int
+type MasterPassword = Text
+type AccessCode = Text
+type Markdown = Text
+
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
+DocInfo
+ docId DocId
+ accCode AccessCode Maybe
+ version Version
+ UniqueDocId docId
+ deriving Show Eq
+|]
diff --git a/src/Karasu/Server.hs b/src/Karasu/Server.hs
@@ -0,0 +1,33 @@
+-- | All the server related stuff
+module Karasu.Server (karasuServer, staticServer, apiServer) where
+
+import Karasu.Api
+import Karasu.Environment
+import Karasu.Handler
+import Karasu.Handlers.ApiCreateDoc
+import Karasu.Handlers.ApiEditDoc
+import Karasu.Handlers.ApiGetDoc
+import Karasu.Handlers.ApiPreviewDoc
+import Karasu.Handlers.Static
+
+import Servant
+
+-- * Static server, which serves all the static files
+staticServer :: Server StaticFiles
+staticServer = serveDirectoryWebApp "static"
+
+-- * API server, which serves all APIs, of course
+
+-- | API server with KHandler wrapper
+-- We will need to use hoistServer to apply the
+-- natural transformation KHandler ~> Handler
+apiServerK :: ServerT ReqApi KHandler
+apiServerK = createDoc :<|> editDoc :<|> getDoc :<|> previewDoc
+
+-- | Transformed server
+apiServer :: KarasuEnv -> Server ReqApi
+apiServer env = hoistServer reqApi (nt env) apiServerK
+
+-- * Combined server
+karasuServer :: KarasuEnv -> Server KarasuApi
+karasuServer env = apiServer env :<|> staticServer
diff --git a/stack.yaml b/stack.yaml
@@ -0,0 +1,7 @@
+resolver: lts-14.27
+
+packages:
+- .
+
+extra-deps: []
+
