Browse Source

Add a simple CLI management tool with a few commands

tags/v0.1.0
Gil Mizrahi 11 months ago
parent
commit
029be6ac6f
7 changed files with 108 additions and 18 deletions
  1. +1
    -1
      app/Main.hs
  2. +4
    -1
      bulletin-app.cabal
  3. +1
    -1
      readme.md
  4. +1
    -1
      src/Web/Bulletin.hs
  5. +85
    -0
      src/Web/Bulletin/Cli.hs
  6. +13
    -4
      src/Web/Bulletin/DbAccess.hs
  7. +3
    -10
      src/Web/Bulletin/Server.hs

+ 1
- 1
app/Main.hs View File

@@ -1,4 +1,4 @@
import Web.Bulletin

main :: IO ()
main = run
main = cli

+ 4
- 1
bulletin-app.cabal View File

@@ -19,12 +19,13 @@ library
Web.Bulletin.Actions.Posts
Web.Bulletin.Actions.MyUsers
Web.Bulletin.Actions.Profile
Web.Bulletin.Cli
Web.Bulletin.Config
Web.Bulletin.DbAccess
Web.Bulletin.Html
Web.Bulletin.Model
Web.Bulletin.Router
Web.Bulletin.Run
Web.Bulletin.Server
Web.Bulletin.Style
Web.Bulletin.Validation
Web.Bulletin.RegTokens
@@ -54,6 +55,8 @@ library
-- markdown
, cheapskate
, cheapskate-lucid
-- cli
, optparse-generic

executable bulletin-app
hs-source-dirs: app


+ 1
- 1
readme.md View File

@@ -20,7 +20,7 @@ stack build
## Run with

```sh
PORT=8080 SCOTTY_ENV='Development' CONN_STRING='file:/tmp/bullet.db' stack exec bulletin-app
PORT=8080 SCOTTY_ENV='Development' CONN_STRING='file:/tmp/bullet.db' stack exec -- bulletin-app serve
```

where `/tmp/bullet.db` is the path to the database file.


+ 1
- 1
src/Web/Bulletin.hs View File

@@ -8,4 +8,4 @@ where
import Web.Bulletin.Config as Export
import Web.Bulletin.Model as Export
import Web.Bulletin.Router as Export
import Web.Bulletin.Run as Export
import Web.Bulletin.Cli as Export

+ 85
- 0
src/Web/Bulletin/Cli.hs View File

@@ -0,0 +1,85 @@
{-# LANGUAGE DataKinds, DeriveGeneric, FlexibleInstances, OverloadedStrings, StandaloneDeriving, TypeOperators #-} -- for optparse-generic

{-# language NamedFieldPuns #-}
{-# language OverloadedStrings #-}

module Web.Bulletin.Cli where

import Options.Generic
import Data.Int (Int64)
import Data.List (transpose)
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.IO as TL

import qualified Database.Persist.Sql as P
import qualified Web.Scotty.Sqlite.Users as Users
import qualified Web.Bulletin.DbAccess as DB
import Web.Bulletin.Config
import Web.Bulletin.Server (run)


cli :: IO ()
cli = do
cfg <- setup
command <- unwrapRecord "Bulletin board website"
case command of
Serve -> do
run cfg

List_users -> do
TL.putStr . showUsers =<< Users.getAllUsers (cfgUsersStateInfo cfg)

Generate_invites { amount } -> do
_ <- DB.generateTokens' cfg (P.toSqlKey 0) amount
tokens <- DB.getTokens' cfg (P.toSqlKey 0)
T.putStrLn "Available tokens for you:"
mapM_ (T.putStrLn . (<>) "/register/") tokens

setup :: IO Config
setup = do
ses <- Users.initSessionStore
cfg <- getConfig ses
Users.dbMigrations (Users.siPool (cfgUsersStateInfo cfg))
DB.dbMigrations cfg
pure cfg

data Command w
= Serve
| List_users
| Generate_invites { amount :: w ::: Int <?> "How many invite to generate" }
-- | Reset_user_password { username :: TL.Text }
-- | Ban_user { username :: TL.Text }
-- | Reset_user_info { username :: TL.Text }
-- | Promote_to_admin { username :: TL.Text }
deriving Generic

instance ParseRecord (Command Wrapped)
deriving instance Show (Command Unwrapped)

showUsers :: [P.Entity Users.Login] -> TL.Text
showUsers list =
let
toprowfields = ["user_id", "username"]
fields = map showUserFields list
maxlens = map (maximum . map TL.length) $ zipWith (:) toprowfields $ transpose fields
toprow = showRow ' ' maxlens toprowfields
seperator = "|-" <> TL.intercalate "-+-" (zipWith (pad '-') maxlens (map (const "") toprowfields)) <> "-|"
in
TL.unlines $ toprow : seperator : map (showRow ' ' maxlens) fields
showRow :: Char -> [Int64] -> [TL.Text] -> TL.Text
showRow c maxlens fields =
wrapBlock $ TL.intercalate " | " $ zipWith (pad c) maxlens fields

wrapBlock :: TL.Text -> TL.Text
wrapBlock a = "| " <> a <> " |"

pad :: Char -> Int64 -> TL.Text -> TL.Text
pad char maxlen field = field <> TL.replicate (maxlen - TL.length field) (TL.singleton char)

showUserFields :: P.Entity Users.Login -> [TL.Text]
showUserFields (P.Entity uid user) =
[ TL.pack $ show $ P.fromSqlKey uid
, Users.loginUsername user
]

+ 13
- 4
src/Web/Bulletin/DbAccess.hs View File

@@ -196,9 +196,7 @@ getUserInfoSql username = do
getTokensByUserId :: Config -> Users.LoginId -> IO [T.Text]
getTokensByUserId cfg uid = do
generateTokens cfg uid
results <- runDB cfg $
P.selectList [RegistrationTokenUserId P.==. uid] []
pure $ registrationTokenToken . P.entityVal <$> results
getTokens' cfg uid

isValidToken :: Config -> T.Text -> IO Bool
isValidToken cfg =
@@ -235,10 +233,21 @@ generateTokens cfg uid = do
numOfTokensToGenerate =
expectedMaxTokens - currentMaxTokens
pure numOfTokensToGenerate
tokens <- generateRandomTokens numOfTokensToGenerate uid
void $ generateTokens' cfg uid numOfTokensToGenerate

generateTokens' :: Config -> Users.LoginId -> Int -> IO [T.Text]
generateTokens' cfg uid amount = do
tokens <- generateRandomTokens amount uid
runDB cfg $
mapM_ (P.insert . RegistrationToken uid) tokens
pure tokens

getTokens' :: Config -> Users.LoginId -> IO [T.Text]
getTokens' cfg uid = do
results <- runDB cfg $
P.selectList [RegistrationTokenUserId P.==. uid] []
pure $ registrationTokenToken . P.entityVal <$> results

getCurrentMaxTokensAmount :: Users.LoginId -> Sql (Maybe (P.Entity MaxRegistrationTokens))
getCurrentMaxTokensAmount uid = P.getBy (UserId uid)


src/Web/Bulletin/Run.hs → src/Web/Bulletin/Server.hs View File

@@ -1,17 +1,14 @@
{-# language OverloadedStrings #-}

module Web.Bulletin.Run where
module Web.Bulletin.Server where

import qualified Network.Wai as Wai
import qualified Network.Wai.Middleware.RequestLogger as WaiLog
import qualified Web.Scotty as S
import qualified Data.Text.Lazy as TL
import qualified Network.HTTP.Types as HTTP
import Control.Monad.IO.Class (liftIO)
import qualified Lucid as H

import qualified Web.Scotty.Sqlite.Users as Users
import qualified Web.Bulletin.DbAccess as DB
import Web.Bulletin.Config
import Web.Bulletin.Html
import Web.Bulletin.Router
@@ -20,12 +17,8 @@ import Web.Bulletin.Router
-- Runner --
------------

run :: IO ()
run = do
ses <- Users.initSessionStore
cfg <- getConfig ses
liftIO $ Users.dbMigrations (Users.siPool (cfgUsersStateInfo cfg))
liftIO $ DB.dbMigrations cfg
run :: Config -> IO ()
run cfg = do
S.scotty (cfgPort cfg) (myApp cfg)

myApp :: Config -> S.ScottyM ()

Loading…
Cancel
Save