Browse Source

Enable open registration by default, add option to disable

tags/v0.2.0.0
Gil Mizrahi 10 months ago
parent
commit
fd9cec30df
7 changed files with 123 additions and 60 deletions
  1. +1
    -1
      bulletin-app.cabal
  2. +18
    -9
      readme.md
  3. +16
    -6
      src/Web/Bulletin/Actions/MyUsers.hs
  4. +4
    -4
      src/Web/Bulletin/Actions/Posts.hs
  5. +2
    -2
      src/Web/Bulletin/Actions/Profile.hs
  6. +81
    -37
      src/Web/Bulletin/Config.hs
  7. +1
    -1
      src/Web/Bulletin/Router.hs

+ 1
- 1
bulletin-app.cabal View File

@@ -1,5 +1,5 @@
name: bulletin-app
version: 0.1.0.0
version: 0.2.0.0
synopsis: A simple bulletin board web app using scotty
description: Please see readme.md
homepage: https://gitlab.com/gilmi/bulletin-app


+ 18
- 9
readme.md View File

@@ -20,12 +20,13 @@ stack build
## Run with

```sh
VISIBLE='Public' PORT=8080 SCOTTY_ENV='Development' CONN_STRING='file:/tmp/bullet.db' stack exec -- bulletin-app serve
REGISTRATION='OpenRegistration' VISIBLE='Public' 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.

Note that Development environment means the insecure flag on the cookies is set off. Using Production environment will set it on.
Note that Development environment means the insecure flag on the cookies is set off.
Using Production environment will set it on.

### How to register

@@ -36,36 +37,44 @@ Instead, we invite users to register.

When a user reaches a certain level they can start inviting
other people. The leveling formula is described in the
[Web.Bulletin.RegTokens.calcLevel](src/Web/Bulletin/RegTokens.hs) function.
[Web.Bulletin.Database.RegTokens.calcLevel](src/Web/Bulletin/Database/RegTokens.hs) function.

So once a user posts 10 times they can now invite 2 friends to register.
The [/invite](http://localhost:8080/invite) provides the registration links.

#### Generate an invite CLI

To register the first user, run the following command to generate an invite:
If you are using `REGISTRATION='InvitesOnly'`, users would only be able to
register via a special link (which each is a single user only invite).

These links can be generated by active users that have reached higher levels,
or via the CLI command.

Run the following command to generate an invite:

```sh
CONN_STRING='file:/tmp/bullet.db' stack exec -- bulletin-app generate_invites --amount 1
```

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

and then go to the link in the browse to register.
and then go to the link in the browser to register.

### Configuration

The following settings are available using environment variables:

- `SCOTTY_ENV`: server environment, three options:
- `Development` - One major thing to note here is that cookies are not flagged as `secure` so it can be used without TLS
- `Development` - (*Default*) One major thing to note here is that cookies are not flagged as `secure` so it can be used without TLS
- `Production` - Cookies are marked as secure so can only really work with TLS.
- `Testing` - Not really in use at the moment, sorry for being lazy and not writing tests.
- `CONN_STRING` - sqlite3 connection string ([see URI filename examples](https://www.sqlite.org/c3ref/open.html)).
- `CONN_STRING` - (**Required**) sqlite3 connection string ([see URI filename examples](https://www.sqlite.org/c3ref/open.html)).
- `PORT`
- `VISIBLE` - Should the site content be available to users that are not logged in?
- `Public` - yes.
- `Public` - (*Default*) yes.
- `Private` - no.
- `REGISTRATION` - Should registration be available to anyone?
- `OpenRegistration` - (*Default*) yes.
- `InvitesOnly` - no.

### Commands



+ 16
- 6
src/Web/Bulletin/Actions/MyUsers.hs View File

@@ -7,6 +7,7 @@
module Web.Bulletin.Actions.MyUsers where


import Control.Monad (when)
import Data.List (intersperse)
import Control.Monad.IO.Class (liftIO)
import qualified Lucid as H
@@ -25,8 +26,9 @@ import Web.Bulletin.Html
-- | Router for all user actions
router :: Config -> S.ScottyM ()
router cfg = do
-- Provide a temporary way to register without invite tokens
-- NewUser.router (cfgUsersStateInfo cfg) mytemplate
when (cfgRegistration cfg == OpenRegistration) $
NewUser.router (cfgUsersStateInfo cfg) mytemplate

-- A page for registering a new user
S.get "/register/:token" $ do
@@ -50,8 +52,8 @@ router cfg = do
-- * Actions

-- | Returns html to welcome the user, providing links to register/login or logout.
loginOrLogout :: Maybe (P.Entity Users.Login) -> S.ActionM Html
loginOrLogout muser = do
loginOrLogout :: Config -> Maybe (P.Entity Users.Login) -> S.ActionM Html
loginOrLogout cfg muser = do
pure $
H.div_ [ H.class_ "welcome" ] $
case fmap P.entityVal muser of
@@ -69,7 +71,15 @@ loginOrLogout muser = do
]
Nothing ->
mconcat
[ " " <> H.a_ [ H.href_ "/login" ] "Log in"
[ "[ "
, mconcat $ intersperse " | " $
( if cfgRegistration cfg == OpenRegistration
then (:) (H.a_ [ H.href_ "/register" ] "Register")
else id
)
[ H.a_ [ H.href_ "/login" ] "Log in"
]
, " ]"
]

myRegisterGet :: Config -> T.Text -> S.ActionM ()
@@ -106,7 +116,7 @@ myInvite cfg user@(P.Entity uid _) = do
| size == 0 = "no tokens"
| size == 1 = "1 token"
| otherwise = show size <> " tokens"
welcome <- loginOrLogout (Just user)
welcome <- loginOrLogout cfg (Just user)
S.html $
H.renderText $
template


+ 4
- 4
src/Web/Bulletin/Actions/Posts.hs View File

@@ -150,7 +150,7 @@ displayAllPosts cfg = do

userPosts :: Config -> Users.Username -> S.ActionM ()
userPosts cfg queriedUsername = do
io <- Users.withMaybeLogin (cfgUsersStateInfo cfg) $ MyUsers.loginOrLogout
io <- Users.withMaybeLogin (cfgUsersStateInfo cfg) $ MyUsers.loginOrLogout cfg
posts <- liftIO $ DB.getAuthorPostsByUsername cfg queriedUsername
S.html $
H.renderText $
@@ -165,7 +165,7 @@ userPosts cfg queriedUsername = do

userComments :: Config -> Users.Username -> S.ActionM ()
userComments cfg queriedUsername = do
io <- Users.withMaybeLogin (cfgUsersStateInfo cfg) $ MyUsers.loginOrLogout
io <- Users.withMaybeLogin (cfgUsersStateInfo cfg) $ MyUsers.loginOrLogout cfg
comms <- liftIO $ DB.getAuthorCommentsByUsername cfg queriedUsername
S.html $
H.renderText $
@@ -196,7 +196,7 @@ displayPostWithComments :: Config -> PostId -> Html -> S.ActionM ()
displayPostWithComments cfg pid newcommenthtml = do
mpost <- liftIO $ DB.runDB cfg $ DB.getPostWithComments pid
minfo <- maybe (pure Nothing) (liftIO . DB.getUserInfoById cfg) =<< Users.getSession (cfgUsersStateInfo cfg)
io <- Users.withMaybeLogin (cfgUsersStateInfo cfg) $ MyUsers.loginOrLogout
io <- Users.withMaybeLogin (cfgUsersStateInfo cfg) $ MyUsers.loginOrLogout cfg
case mpost of
Just (pb@(post, _, _), comments) ->
S.html $
@@ -222,7 +222,7 @@ displayPostWithComments cfg pid newcommenthtml = do

servePostForm :: Config -> Route -> NewPostErrors -> TL.Text -> TL.Text -> S.ActionM ()
servePostForm cfg route errs title content = do
io <- Users.withMaybeLogin (cfgUsersStateInfo cfg) $ MyUsers.loginOrLogout
io <- Users.withMaybeLogin (cfgUsersStateInfo cfg) $ MyUsers.loginOrLogout cfg
S.html $
H.renderText $
template


+ 2
- 2
src/Web/Bulletin/Actions/Profile.hs View File

@@ -75,7 +75,7 @@ addPriv cfg user =

profileGet :: Config -> Maybe (P.Entity Users.Login, UserPrivilege) -> Users.Username -> S.ActionM ()
profileGet cfg muser queriedUsername = do
io <- Users.withMaybeLogin (cfgUsersStateInfo cfg) $ MyUsers.loginOrLogout
io <- Users.withMaybeLogin (cfgUsersStateInfo cfg) $ MyUsers.loginOrLogout cfg
mresult <- liftIO $ DB.getUserInfoByUsername cfg queriedUsername
profileResponse io noProfileErrors muser queriedUsername mresult

@@ -103,7 +103,7 @@ profilePost cfg (P.Entity uid user, priv) username displayname about = do

submitProfileChanges :: Config -> (Users.LoginId, UserPrivilege) -> UserInfo -> Users.Displayname -> TL.Text -> S.ActionM ()
submitProfileChanges cfg (uid, priv) userInfo displayname about = do
io <- Users.withMaybeLogin (cfgUsersStateInfo cfg) $ MyUsers.loginOrLogout
io <- Users.withMaybeLogin (cfgUsersStateInfo cfg) $ MyUsers.loginOrLogout cfg
let
errs = validateProfile displayname about
if hasProfileErrors errs


+ 81
- 37
src/Web/Bulletin/Config.hs View File

@@ -2,18 +2,23 @@

The following settings are available using environment variables:

- @SCOTTY_ENV@: server environment, three options:
- @Development@ - One major thing to note here is that cookies are not flagged as @secure@ so it can be used without TLS
- @Production@ - Cookies are marked as secure so can only really work with TLS.
- @Testing@ - Not really in use at the moment, sorry for being lazy and not writing tests.
- @CONN_STRING@ - sqlite3 connection string ([see URI filename examples](https://www.sqlite.org/c3ref/open.html)).
- @PORT@
- @VISIBLE@ - Should the site content be available to users that are not logged in?
- @Public@ - yes.
- @Private@ - no.
* @SCOTTY_ENV@: server environment, three options:
* @Development@ - One major thing to note here is that cookies are not flagged as @secure@ so it can be used without TLS
* @Production@ - Cookies are marked as secure so can only really work with TLS.
* @Testing@ - Not really in use at the moment, sorry for being lazy and not writing tests.
* @CONN_STRING@ - sqlite3 connection string ([see URI filename examples](https://www.sqlite.org/c3ref/open.html)).
* @PORT@
* @VISIBLE@ - Should the site content be available to users that are not logged in?
* @Public@ - yes.
* @Private@ - no.
* @REGISTRATION@ - Should registration be available to anyone?
* @OpenRegistration@ - yes.
* @InvitesOnly@ - no.

-}

{-# language TypeApplications #-}

module Web.Bulletin.Config where

import qualified Data.Text as T
@@ -24,13 +29,16 @@ import System.Environment (lookupEnv)
import GHC.Conc (numCapabilities)


-- * General

-- | Configuration environment and state
data Config
= Config
{ cfgEnv :: Environment -- ^ Working environment
, cfgUsersStateInfo :: Users.StateInfo -- ^ @my-scotty-users@ state
, cfgPort :: Port -- ^ Port
, cfgVisibility :: Visibility -- ^ public or private website
, cfgVisibility :: Visibility -- ^ Public or private website
, cfgRegistration :: Registration -- ^ Open or closed registration
}

-- | Read environment variables and generate a config
@@ -38,6 +46,7 @@ getConfig :: Users.SessionStore -> IO Config
getConfig ses = do
env <- getEnv
visibility <- getVisibility
reg <- getRegistration
let
mode = case env of
Production -> Users.Production
@@ -45,7 +54,9 @@ getConfig ses = do
Testing -> Users.Development
pool <- getPool env
port <- getPort env
pure $ Config env (Users.StateInfo pool ses mode) port visibility
pure $ Config env (Users.StateInfo pool ses mode) port visibility reg

-- ** Visibility

-- | @VISIBLE@ env var: Should the site content be available to users that are not logged in?
data Visibility
@@ -53,6 +64,48 @@ data Visibility
| Private -- ^ No.
deriving (Eq, Read, Show, Enum, Bounded)

-- | Get the @VISIBLE@ variable. If none is provided uses @Public@
getVisibility :: IO Visibility
getVisibility =
maybe Public readVisibility <$> lookupEnv "VISIBLE"

-- | Parse @Visibility@
readVisibility :: String -> Visibility
readVisibility str =
case reads str of
[(visible, "")] -> visible
_ -> error $ unlines $
[ "Could not parse: '" <> str <> "' as a valid environment options."
, "Expecting one of the following:"
] <>
map (("- " <>) . show @Visibility) [ minBound .. maxBound ]

-- ** Registration

-- | @REGISTRATION@ env var: Should registration be available to anyone?
data Registration
= OpenRegistration -- ^ Yes.
| InvitesOnly -- ^ No.
deriving (Eq, Read, Show, Enum, Bounded)

-- | Get the @REGISTRATION@ variable. If none is provided uses @OpenRegistration@
getRegistration :: IO Registration
getRegistration =
maybe OpenRegistration readRegistration <$> lookupEnv "REGISTRATION"

-- | Parse @Registration@
readRegistration :: String -> Registration
readRegistration str =
case reads str of
[(reg, "")] -> reg
_ -> error $ unlines $
[ "Could not parse: '" <> str <> "' as a valid environment options."
, "Expecting one of the following:"
] <>
map (("- " <>) . show @Registration) [ minBound .. maxBound ]

-- ** Environment

-- | @SCOTTY_ENV@ env var: server environment
data Environment
= Development -- ^ One major thing to note here is that cookies are not flagged as @secure@ so it can be used without TLS
@@ -76,35 +129,7 @@ readEnv str =
] <>
map (("- " <>) . show @Environment) [ minBound .. maxBound ]

getVisibility :: IO Visibility
getVisibility =
maybe Public readVisibility <$> lookupEnv "VISIBLE"

readVisibility :: String -> Visibility
readVisibility str =
case reads str of
[(visible, "")] -> visible
_ -> error $ unlines $
[ "Could not parse: '" <> str <> "' as a valid environment options."
, "Expecting one of the following:"
] <>
map (("- " <>) . show @Visibility) [ minBound .. maxBound ]

getPool :: Environment -> IO PSqlite3.ConnectionPool
getPool env = do
cs <- getConnectionString env
let
poolSize = ceiling (fromIntegral numCapabilities / 2)
case env of
Development -> Log.runStderrLoggingT
(PSqlite3.createSqlitePool cs poolSize)
Production -> Log.runStderrLoggingT
(PSqlite3.createSqlitePool cs poolSize)
Testing -> Log.runNoLoggingT
(PSqlite3.createSqlitePool cs poolSize)
-- ** Port

type Port = Int

@@ -129,6 +154,8 @@ getPort env = do
Production -> 443
Testing -> 8000

-- ** DB Connection

type ConnectionString = T.Text

-- | Get the connection string variable. This is mandatory.
@@ -145,3 +172,17 @@ getConnectionString e =
-- Production ->
_ ->
maybe (error "could not find parameter 'CONN_STRING'") T.pack <$> lookupEnv "CONN_STRING"

-- | Create the right sqlite3 connection pool according to the environment.
getPool :: Environment -> IO PSqlite3.ConnectionPool
getPool env = do
cs <- getConnectionString env
let
poolSize = ceiling (fromIntegral numCapabilities / 2)
case env of
Development -> Log.runStderrLoggingT
(PSqlite3.createSqlitePool cs poolSize)
Production -> Log.runStderrLoggingT
(PSqlite3.createSqlitePool cs poolSize)
Testing -> Log.runNoLoggingT
(PSqlite3.createSqlitePool cs poolSize)

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

@@ -56,7 +56,7 @@ router cfg = do
index :: Config -> S.ActionM ()
index cfg = do
posts <- Posts.displayAllPosts cfg
io <- Users.withMaybeLogin (cfgUsersStateInfo cfg) MyUsers.loginOrLogout
io <- Users.withMaybeLogin (cfgUsersStateInfo cfg) $ MyUsers.loginOrLogout cfg
S.html $
H.renderText $
template


Loading…
Cancel
Save