├── Setup.hs ├── .gitignore ├── conf ├── stack.yaml ├── schema.sql ├── Routes.hs ├── LICENSE ├── Database ├── Schema.hs ├── Internal.hs ├── Posts.hs └── Users.hs ├── Database.hs ├── Mailer.hs ├── basilica.cabal ├── Types.hs ├── Sockets.hs ├── Main.hs └── README.md /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | cabal.sandbox.config 3 | .cabal-sandbox/ 4 | *.db 5 | do/ 6 | -------------------------------------------------------------------------------- /conf: -------------------------------------------------------------------------------- 1 | port = 3000 2 | dbpath = "basilica.db" 3 | client-origin = "http://localhost:3333" 4 | client-url = "http://localhost:3333" 5 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | 3 | packages: 4 | - '.' 5 | 6 | extra-deps: 7 | - suspend-0.2.0.0 8 | - timers-0.2.0.3 9 | 10 | resolver: lts-10.4 11 | -------------------------------------------------------------------------------- /schema.sql: -------------------------------------------------------------------------------- 1 | CREATE TABLE posts ( 2 | id INTEGER PRIMARY KEY NOT NULL, 3 | id_user INTEGER NOT NULL REFERENCES users(id), 4 | content TEXT NOT NULL, 5 | id_parent INTEGER NULL REFERENCES posts(id), 6 | at TEXT NOT NULL 7 | ); 8 | 9 | CREATE TABLE users ( 10 | id INTEGER PRIMARY KEY NOT NULL, 11 | name TEXT NOT NULL UNIQUE, 12 | email TEXT NOT NULL UNIQUE 13 | ); 14 | 15 | CREATE TABLE tokens ( 16 | id INTEGER PRIMARY KEY NOT NULL, 17 | token TEXT UNIQUE NOT NULL, 18 | id_user INTEGER NOT NULL, 19 | FOREIGN KEY(id_user) REFERENCES users(id) 20 | ); 21 | 22 | CREATE TABLE codes ( 23 | code TEXT PRIMARY KEY NOT NULL, 24 | generated_at TEXT NOT NULL, 25 | valid INTEGER NOT NULL, 26 | id_user INTEGER NOT NULL, 27 | FOREIGN KEY(id_user) REFERENCES users(id) 28 | ); 29 | -------------------------------------------------------------------------------- /Routes.hs: -------------------------------------------------------------------------------- 1 | module Routes 2 | ( Request(..) 3 | , Response(..) 4 | ) where 5 | 6 | import ClassyPrelude 7 | import Types 8 | 9 | type Name = Text 10 | 11 | data Request = GetPost ID 12 | | ListPosts PostQuery 13 | | CreatePost (Maybe ID) Token Text 14 | | CreateCode EmailAddress 15 | | CreateToken Code 16 | | CreateUser EmailAddress Name 17 | 18 | data Response = NewPost ResolvedPost 19 | | ExistingPost ResolvedPost 20 | | PostList [ResolvedPost] 21 | | NewToken ResolvedToken 22 | | NewUser ResolvedCode 23 | | NewCode ResolvedCode 24 | | BadToken 25 | | BadCode 26 | | UnknownEmail 27 | | InvalidUsername 28 | | ExistingNameOrEmail 29 | | BadRequest LText 30 | | PostNotFound ID 31 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 Ian Henry 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /Database/Schema.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE QuasiQuotes #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | 9 | module Database.Schema where 10 | 11 | import ClassyPrelude 12 | import Database.Persist.TH 13 | 14 | type EmailAddress = Text 15 | type Token = Text 16 | 17 | share [mkPersist sqlSettings] [persistLowerCase| 18 | UserRow sql=users 19 | name Text 20 | email EmailAddress 21 | UniqueName name 22 | UniqueEmail email 23 | deriving Show 24 | CodeRow sql=codes 25 | code Text 26 | generatedAt UTCTime sql="generated_at" 27 | valid Bool 28 | userId UserRowId sql="id_user" 29 | Primary code 30 | deriving Show 31 | TokenRow sql=tokens 32 | token Token 33 | userId UserRowId sql="id_user" 34 | UniqueToken token 35 | deriving Show 36 | PostRow sql=posts 37 | content Text 38 | at UTCTime 39 | userId UserRowId sql="id_user" 40 | parentId PostRowId Maybe sql="id_parent" 41 | deriving Show 42 | |] 43 | -------------------------------------------------------------------------------- /Database.hs: -------------------------------------------------------------------------------- 1 | module Database 2 | ( module X 3 | , withDatabase 4 | , DatabaseM 5 | , Database(..) 6 | ) where 7 | 8 | import ClassyPrelude 9 | import Control.Monad.Logger (MonadLogger,) 10 | import Control.Monad.Trans.Control (MonadBaseControl) 11 | import Crypto.Random.DRBG 12 | import Database.Internal 13 | import Database.Persist.Sql (withSqlConn, SqlBackend) 14 | import Database.Persist.Sqlite (LogFunc, wrapConnection) 15 | import Database.Posts as X 16 | import Database.Sqlite (Connection, open, prepare, step) 17 | import Database.Users as X 18 | import Types as X 19 | 20 | enableForeignKeys :: Connection -> IO () 21 | enableForeignKeys conn = prepare conn "PRAGMA foreign_keys = ON;" >>= void . step 22 | 23 | createSqliteBackend :: Text -> LogFunc -> IO SqlBackend 24 | createSqliteBackend connStr logFunc = do 25 | conn <- open connStr 26 | enableForeignKeys conn 27 | wrapConnection conn logFunc 28 | 29 | withDatabase :: (MonadIO m, MonadLogger m, MonadBaseControl IO m) => Text -> (Database -> m a) -> m a 30 | withDatabase dbPath f = do 31 | rng <- liftIO (newGenIO :: IO HashDRBG) 32 | rngSlot <- newMVar rng 33 | withSqlConn (createSqliteBackend dbPath) $ \conn -> 34 | f Database { dbConn = conn 35 | , dbRNG = rngSlot 36 | } 37 | -------------------------------------------------------------------------------- /Mailer.hs: -------------------------------------------------------------------------------- 1 | module Mailer 2 | ( Email(..) 3 | , sendMail 4 | , easyEmail 5 | , Mailer 6 | , newMailer 7 | ) where 8 | 9 | import ClassyPrelude 10 | import Control.Lens ((?~), (&)) 11 | import Network.Wreq 12 | import Network.HTTP.Client (HttpException) 13 | 14 | data Mailer = Mailer { mailerKey :: ByteString } 15 | 16 | newMailer :: ByteString -> Mailer 17 | newMailer = Mailer 18 | 19 | data Email = Email { emailTo :: Text 20 | , emailFromName :: Text 21 | , emailFromEmail :: Text 22 | , emailReplyTo :: Text 23 | , emailSubject :: Text 24 | , emailBody :: Text 25 | } 26 | 27 | easyEmail :: Text -> Text -> Text -> Email 28 | easyEmail to subject body = 29 | Email { emailTo = to 30 | , emailFromName = "Basilica" 31 | , emailFromEmail = "ianthehenry+basilica@gmail.com" 32 | , emailReplyTo = "ianthehenry+basilica@gmail.com" 33 | , emailSubject = subject 34 | , emailBody = body 35 | } 36 | 37 | emailForm :: Email -> [FormParam] 38 | emailForm Email{..} = [ "to" := emailTo 39 | , "from" := intercalate "" [emailFromName, " <", emailFromEmail, ">"] 40 | , "h:Reply-To" := emailReplyTo 41 | , "subject" := emailSubject 42 | , "text" := emailBody 43 | ] 44 | 45 | sendMail :: Mailer -> Email -> IO () 46 | sendMail Mailer{mailerKey} email = catch (void sendEmail) logError 47 | where 48 | sendEmail = postWith opts "https://api.mailgun.net/v3/mail.basilica.horse/messages" form 49 | logError :: HttpException -> IO () 50 | logError = print 51 | opts = defaults & auth ?~ basicAuth "api" mailerKey 52 | form = emailForm email 53 | -------------------------------------------------------------------------------- /Database/Internal.hs: -------------------------------------------------------------------------------- 1 | module Database.Internal 2 | ( module X 3 | , Database(..) 4 | , DatabaseM 5 | , secureRandom 6 | , asInt 7 | , getID 8 | , fromInt 9 | , runInsert 10 | , runQuery 11 | , getOne 12 | ) where 13 | 14 | import ClassyPrelude 15 | import Control.Monad.Reader (asks) 16 | import Control.Monad.Trans.Control 17 | import Crypto.Random.DRBG (genBytes, HashDRBG) 18 | import Data.ByteString.Base16 as BS (encode) 19 | import Database.Persist 20 | import Database.Persist.Sql 21 | import Database.Sqlite (SqliteException(..), Error(..)) 22 | import Types as X 23 | 24 | data Database = Database { dbConn :: SqlBackend 25 | , dbRNG :: MVar HashDRBG 26 | } 27 | 28 | type DatabaseM a = ReaderT Database IO a 29 | 30 | secureRandom :: DatabaseM Text 31 | secureRandom = do 32 | rng <- asks dbRNG 33 | bytes <- liftIO $ modifyMVar rng $ \gen -> 34 | let Right (randomBytes, newGen) = genBytes 16 gen in 35 | pure (newGen, randomBytes) 36 | pure $ (decodeUtf8 . BS.encode) bytes 37 | 38 | asInt :: PersistEntity a => Key a -> Int 39 | asInt key = let [PersistInt64 x] = keyToValues key in fromIntegral x 40 | 41 | getID :: PersistEntity a => Entity a -> Int 42 | getID = asInt . entityKey 43 | 44 | fromInt :: PersistEntity a => Int -> Key a 45 | fromInt key = let Right x = keyFromValues [PersistInt64 (fromIntegral key)] in x 46 | 47 | runInsert :: (PersistEntity a, PersistEntityBackend a ~ SqlBackend) => a -> DatabaseM (Maybe (Key a)) 48 | runInsert entity = (Just <$> runQuery (insert entity)) `catch` swallowConstraintError 49 | where swallowConstraintError SqliteException{seError = ErrorConstraint} = pure Nothing 50 | swallowConstraintError e = throwM e 51 | 52 | runQuery :: (MonadIO m, MonadReader Database m, MonadBaseControl IO m) => SqlPersistT m a -> m a 53 | runQuery query = runSqlConn query =<< asks dbConn 54 | 55 | getOne :: (MonadIO m, MonadReader Database m, MonadBaseControl IO m) => (a -> b) -> SqlPersistT m [a] -> m (Maybe b) 56 | getOne f query = fmap f . listToMaybe <$> runQuery query 57 | -------------------------------------------------------------------------------- /basilica.cabal: -------------------------------------------------------------------------------- 1 | name: basilica 2 | version: 0.1.0.0 3 | license: MIT 4 | license-file: LICENSE 5 | author: Ian Henry 6 | maintainer: ianthehenry@gmail.com 7 | category: Web 8 | build-type: Simple 9 | cabal-version: >=1.10 10 | 11 | executable basilica 12 | main-is: Main.hs 13 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 14 | build-depends: DRBG 15 | , aeson 16 | , base 17 | , classy-prelude 18 | , base16-bytestring 19 | , bytestring 20 | , configurator 21 | , containers 22 | , cryptohash 23 | , filepath 24 | , http-types 25 | , mtl 26 | , transformers 27 | , random 28 | , scotty 29 | , suspend 30 | , text 31 | , time 32 | , timers 33 | , unix-time 34 | , wai 35 | , case-insensitive 36 | , warp 37 | , websockets 38 | , wai-websockets 39 | , io-streams 40 | , wreq 41 | , lens 42 | , http-client 43 | , lifted-base 44 | , persistent-sqlite 45 | , persistent 46 | , persistent-template 47 | , monad-logger 48 | , esqueleto 49 | , monad-control 50 | 51 | other-modules: Database 52 | , Database.Internal 53 | , Database.Posts 54 | , Database.Users 55 | , Database.Schema 56 | , Mailer 57 | , Routes 58 | , Sockets 59 | , Types 60 | 61 | default-extensions: OverloadedStrings 62 | , NoImplicitPrelude 63 | , NamedFieldPuns 64 | , RecordWildCards 65 | , TypeFamilies 66 | , FlexibleContexts 67 | 68 | default-language: Haskell2010 69 | -------------------------------------------------------------------------------- /Database/Posts.hs: -------------------------------------------------------------------------------- 1 | module Database.Posts 2 | ( createPost 3 | , getPosts 4 | , getPost 5 | ) where 6 | 7 | import ClassyPrelude hiding (groupBy, on) 8 | import Database.Esqueleto 9 | import Database.Internal 10 | import Database.Schema 11 | 12 | toResolvedPost :: (Entity PostRow, Value Int, Entity UserRow) -> ResolvedPost 13 | toResolvedPost (postEntity, childCount, userEntity) = ResolvedPost post user 14 | where 15 | postRow = entityVal postEntity 16 | userRow = entityVal userEntity 17 | post = Post { postID = getID postEntity 18 | , postUserID = asInt (postRowUserId postRow) 19 | , postContent = postRowContent postRow 20 | , postAt = postRowAt postRow 21 | , postParentID = asInt <$> postRowParentId postRow 22 | , postCount = unValue childCount 23 | } 24 | user = User { userID = getID userEntity 25 | , userName = userRowName userRow 26 | , userEmail = userRowEmail userRow 27 | } 28 | 29 | postQuery :: (SqlExpr (Entity PostRow) -> SqlQuery ()) -> DatabaseM [ResolvedPost] 30 | postQuery customClause = fmap toResolvedPost <$> runQuery query 31 | where query = select $ from $ \((post `LeftOuterJoin` child) `InnerJoin` user) -> do 32 | on $ (user ^. UserRowId) ==. (post ^. PostRowUserId) 33 | on $ (child ^. PostRowParentId) ==. just (post ^. PostRowId) 34 | customClause post 35 | groupBy (post ^. PostRowId) 36 | orderBy [desc $ post ^. PostRowId] 37 | pure (post, count (child ^. PostRowId), user) 38 | 39 | getPostByKey :: PostRowId -> DatabaseM (Maybe ResolvedPost) 40 | getPostByKey idPost = listToMaybe <$> postQuery (\post -> where_ $ post ^. PostRowId ==. val idPost) 41 | 42 | getPost :: Int -> DatabaseM (Maybe ResolvedPost) 43 | getPost = getPostByKey . fromInt 44 | 45 | getPosts :: PostQuery -> DatabaseM [ResolvedPost] 46 | getPosts PostQuery{..} = postQuery $ \post -> do 47 | maybe (pure ()) (\a -> where_ (post ^. PostRowId >. val a)) (fromInt <$> postQueryAfter) 48 | maybe (pure ()) (\b -> where_ (post ^. PostRowId <. val b)) (fromInt <$> postQueryBefore) 49 | limit (fromIntegral postQueryLimit) 50 | 51 | insertPost :: User -> Text -> Maybe ID -> UTCTime -> DatabaseM (Maybe ResolvedPost) 52 | insertPost User{userID = idUser} content idParent at = do 53 | key <- runInsert postRow 54 | maybe (pure Nothing) getPostByKey key 55 | where postRow = PostRow { postRowUserId = fromInt idUser 56 | , postRowContent = content 57 | , postRowParentId = fromInt <$> idParent 58 | , postRowAt = at 59 | } 60 | 61 | createPost :: User -> Text -> Maybe ID -> DatabaseM (Maybe ResolvedPost) 62 | createPost user content parentID = 63 | insertPost user content parentID =<< liftIO getCurrentTime 64 | -------------------------------------------------------------------------------- /Types.hs: -------------------------------------------------------------------------------- 1 | module Types 2 | ( Post(..) 3 | , PostQuery(..) 4 | , CodeRecord(..) 5 | , TokenRecord(..) 6 | , User(..) 7 | , ResolvedPost(..) 8 | , ResolvedCode(..) 9 | , ResolvedToken(..) 10 | , ID 11 | , EmailAddress 12 | , Token 13 | , Code 14 | ) where 15 | 16 | import ClassyPrelude 17 | import qualified Crypto.Hash.MD5 as MD5 18 | import Data.Aeson ((.=)) 19 | import qualified Data.Aeson as Aeson 20 | import qualified Data.Aeson.Types as Aeson 21 | import qualified Data.ByteString.Base16 as Hex 22 | import Database.Schema (PostRowId, EmailAddress, Token) 23 | 24 | data PostQuery = PostQuery { postQueryBefore :: Maybe ID 25 | , postQueryAfter :: Maybe ID 26 | , postQueryLimit :: Int 27 | } 28 | 29 | data Post = Post { postID :: ID 30 | , postUserID :: ID 31 | , postContent :: Text 32 | , postAt :: UTCTime 33 | , postParentID :: Maybe ID 34 | , postCount :: Int 35 | } 36 | 37 | data CodeRecord = CodeRecord { codeValue :: Code 38 | , codeGeneratedAt :: UTCTime 39 | , codeValid :: Bool 40 | , codeUserID :: ID 41 | } 42 | 43 | data TokenRecord = TokenRecord { tokenID :: ID 44 | , tokenValue :: Token 45 | , tokenUserID :: ID 46 | } 47 | 48 | data User = User { userID :: ID 49 | , userName :: Text 50 | , userEmail :: EmailAddress 51 | } 52 | 53 | data ResolvedPost = ResolvedPost Post User 54 | data ResolvedCode = ResolvedCode CodeRecord User 55 | data ResolvedToken = ResolvedToken TokenRecord User 56 | 57 | postPairs :: Post -> [Aeson.Pair] 58 | postPairs Post{..} = [ "id" .= postID 59 | , "content" .= postContent 60 | , "at" .= postAt 61 | , "count" .= postCount 62 | , "idParent" .= postParentID 63 | ] 64 | 65 | instance Aeson.ToJSON Post where 66 | toJSON post@Post{..} = Aeson.object 67 | ("idUser" .= postUserID : postPairs post) 68 | 69 | gravatar :: Text -> Text 70 | gravatar = decodeUtf8 . Hex.encode . MD5.hash . encodeUtf8 71 | 72 | instance Aeson.ToJSON User where 73 | toJSON User{..} = Aeson.object 74 | [ "id" .= userID 75 | , "name" .= userName 76 | , "face" .= Aeson.object ["gravatar" .= gravatar userEmail] 77 | ] 78 | 79 | instance Aeson.ToJSON ResolvedPost where 80 | toJSON (ResolvedPost post@Post{..} user) = Aeson.object 81 | ("user" .= user : postPairs post) 82 | 83 | instance Aeson.ToJSON ResolvedToken where 84 | toJSON (ResolvedToken TokenRecord{..} user) = Aeson.object 85 | [ "id" .= tokenID 86 | , "token" .= tokenValue 87 | , "user" .= user 88 | ] 89 | 90 | type ID = Int 91 | type Code = Text 92 | -------------------------------------------------------------------------------- /Sockets.hs: -------------------------------------------------------------------------------- 1 | module Sockets 2 | ( newServer 3 | , Broadcaster 4 | ) where 5 | 6 | import ClassyPrelude 7 | import Control.Concurrent.Lifted 8 | import Control.Concurrent.Suspend (sDelay) 9 | import Control.Concurrent.Timer 10 | import Control.Monad.Trans.Maybe (runMaybeT) 11 | import qualified Data.Aeson as Aeson 12 | import Data.Unique 13 | import Data.UnixTime (UnixTime, getUnixTime, secondsToUnixDiffTime, diffUnixTime) 14 | import qualified Network.HTTP.Types.URI as URI 15 | import qualified Network.WebSockets as WS 16 | import System.IO.Streams.Attoparsec (ParseException) 17 | import Types 18 | 19 | type Broadcaster = Post -> IO () 20 | data Client = Client { clientIdentifier :: Unique 21 | } deriving (Eq, Ord) 22 | 23 | data Beat = Beat { beatLastTime :: UnixTime 24 | , beatConnection :: WS.Connection 25 | } 26 | type ServerState = Map Client Beat 27 | 28 | newServerState :: ServerState 29 | newServerState = mempty 30 | 31 | addClient :: Client -> Beat -> ServerState -> ServerState 32 | addClient = insertMap 33 | 34 | removeClient :: Client -> ServerState -> ServerState 35 | removeClient = deleteMap 36 | 37 | broadcast :: Aeson.ToJSON a => a -> ServerState -> IO () 38 | broadcast message state = 39 | forM_ (toList state) send 40 | where 41 | send Beat{beatConnection} = 42 | WS.sendTextData beatConnection (Aeson.encode message) 43 | 44 | ping :: WS.Connection -> IO () 45 | ping = flip WS.sendPing ("ping" :: ByteString) 46 | 47 | heartbeatIntervalSeconds :: Int64 48 | heartbeatIntervalSeconds = 20 49 | 50 | heartbeat :: MVar ServerState -> IO () 51 | heartbeat db = modifyMVar_ db $ \state -> 52 | mapFromList <$> filterM predicate (mapToList state) 53 | where 54 | maximumDelta = 55 | secondsToUnixDiffTime (heartbeatIntervalSeconds * 2) 56 | predicate (_, Beat{beatLastTime, beatConnection}) = do 57 | now <- getUnixTime 58 | if diffUnixTime now beatLastTime > maximumDelta then do 59 | WS.sendClose beatConnection ("pong better" :: ByteString) 60 | pure False 61 | else do 62 | ping beatConnection 63 | pure True 64 | 65 | newServer :: Aeson.ToJSON a => Chan a -> IO WS.ServerApp 66 | newServer chan = do 67 | state <- newMVar newServerState 68 | _ <- repeatedTimer (heartbeat state) (sDelay heartbeatIntervalSeconds) 69 | _ <- fork $ getChanContents chan >>= mapM_ (makeBroadcast state) 70 | pure (application state) 71 | where 72 | makeBroadcast db post = readMVar db >>= broadcast post 73 | 74 | ifAccept :: WS.PendingConnection -> (WS.Connection -> IO ()) -> IO () 75 | ifAccept pending callback = 76 | case (URI.decodePath . WS.requestPath . WS.pendingRequest) pending of 77 | ([], _) -> WS.acceptRequest pending >>= callback 78 | _ -> WS.rejectRequest pending "You can only connect to / right now." 79 | 80 | handleMessages :: IO () -> WS.Connection -> IO () 81 | handleMessages onPong conn = void $ (runMaybeT . forever) $ do 82 | msg <- lift $ WS.receive conn 83 | case msg of 84 | WS.DataMessage _ _ _ _ -> pure () 85 | WS.ControlMessage cm -> case cm of 86 | WS.Close _ _ -> mzero 87 | WS.Pong _ -> lift onPong 88 | WS.Ping a -> lift (WS.send conn (WS.ControlMessage (WS.Pong a))) 89 | 90 | application_ :: MVar ServerState -> WS.ServerApp 91 | application_ db pending = ifAccept pending $ \conn -> do 92 | clientIdentifier <- newUnique 93 | let client = Client{clientIdentifier} 94 | (`finally` disconnect client) $ do 95 | setTime client conn 96 | handleMessages (setTime client conn) conn 97 | where 98 | withState = modifyMVar_ db 99 | setTime client conn = withState $ \state -> do 100 | beatLastTime <- getUnixTime 101 | let beat = Beat{beatLastTime, beatConnection = conn} 102 | pure $ addClient client beat state 103 | disconnect client = withState (pure . removeClient client) 104 | 105 | application :: MVar ServerState -> WS.ServerApp 106 | application db pending = 107 | (handle connectionExceptions . handle parseExceptions) (application_ db pending) 108 | where 109 | parseExceptions = 110 | const $ throwM WS.ConnectionClosed :: ParseException -> IO () 111 | connectionExceptions = 112 | const $ pure () :: WS.ConnectionException -> IO () 113 | -------------------------------------------------------------------------------- /Database/Users.hs: -------------------------------------------------------------------------------- 1 | module Database.Users 2 | ( createCode 3 | , createToken 4 | , getUser 5 | , createUser 6 | , getUserByToken 7 | ) where 8 | 9 | import ClassyPrelude hiding (on) 10 | import Control.Monad.Reader (asks) 11 | import Data.Time.Clock (diffUTCTime) 12 | import Database.Esqueleto hiding (Connection) 13 | import Database.Internal 14 | import Database.Schema 15 | 16 | toUser :: Entity UserRow -> User 17 | toUser userEntity = User { userID = getID userEntity 18 | , userName = userRowName userRow 19 | , userEmail = userRowEmail userRow 20 | } 21 | where userRow = entityVal userEntity 22 | 23 | getUserByEmail :: EmailAddress -> DatabaseM (Maybe User) 24 | getUserByEmail email = getOne toUser query 25 | where query = select $ from $ \user -> do 26 | where_ $ user ^. UserRowEmail ==. val email 27 | pure user 28 | 29 | getUser :: ID -> DatabaseM (Maybe User) 30 | getUser idUser = getOne toUser query 31 | where query = select $ from $ \user -> do 32 | where_ $ user ^. UserRowId ==. val (fromInt idUser) 33 | pure user 34 | 35 | getUserByToken :: Token -> DatabaseM (Maybe User) 36 | getUserByToken x = getOne toUser query 37 | where query = select $ from $ \(token `InnerJoin` user) -> do 38 | on $ (token ^. TokenRowUserId) ==. (user ^. UserRowId) 39 | where_ $ token ^. TokenRowToken ==. val x 40 | pure user 41 | 42 | insertCode :: CodeRecord -> DatabaseM ID 43 | insertCode CodeRecord{..} = asInt <$> runQuery query 44 | where 45 | query = insert codeRow 46 | codeRow = CodeRow { codeRowCode = codeValue 47 | , codeRowGeneratedAt = codeGeneratedAt 48 | , codeRowValid = codeValid 49 | , codeRowUserId = fromInt codeUserID 50 | } 51 | 52 | createCode :: EmailAddress -> DatabaseM (Maybe ResolvedCode) 53 | createCode email = do 54 | maybeUser <- getUserByEmail email 55 | case maybeUser of 56 | Nothing -> pure Nothing 57 | Just user -> do 58 | code <- newCode user 59 | pure (Just (ResolvedCode code user)) 60 | where 61 | newCode user = do 62 | now <- liftIO getCurrentTime 63 | codeValue <- secureRandom 64 | let code = CodeRecord { codeValue = codeValue 65 | , codeGeneratedAt = now 66 | , codeValid = True 67 | , codeUserID = userID user 68 | } 69 | _ <- insertCode code 70 | pure code 71 | 72 | isCodeValidAt :: CodeRecord -> UTCTime -> Bool 73 | isCodeValidAt CodeRecord{codeValid = False} _ = False 74 | isCodeValidAt CodeRecord{codeValid = True, codeGeneratedAt} at = 75 | diffUTCTime at codeGeneratedAt < oneHour 76 | where oneHour = 60 * 60 77 | 78 | toCodeRecord :: Entity CodeRow -> CodeRecord 79 | toCodeRecord codeEntity = 80 | CodeRecord { codeValue = codeRowCode codeRow 81 | , codeGeneratedAt = codeRowGeneratedAt codeRow 82 | , codeValid = codeRowValid codeRow 83 | , codeUserID = asInt (codeRowUserId codeRow) 84 | } 85 | where codeRow = entityVal codeEntity 86 | 87 | findCode :: Code -> DatabaseM (Maybe CodeRecord) 88 | findCode x = getOne toCodeRecord query 89 | where query = select $ from $ \code -> do 90 | where_ $ code ^. CodeRowCode ==. val x 91 | pure code 92 | 93 | insertToken :: MonadIO m => Text -> CodeRecord -> SqlPersistT m TokenRecord 94 | insertToken token CodeRecord{..} = do 95 | idToken <- insert tokenRow 96 | pure TokenRecord { tokenID = asInt idToken 97 | , tokenValue = token 98 | , tokenUserID = codeUserID 99 | } 100 | where tokenRow = TokenRow { tokenRowToken = token 101 | , tokenRowUserId = fromInt codeUserID 102 | } 103 | 104 | invalidateCode :: MonadIO m => CodeRecord -> SqlPersistT m () 105 | invalidateCode CodeRecord{codeValue} = do 106 | rowCount <- updateCount $ \code -> do 107 | set code [CodeRowValid =. val False] 108 | where_ $ code ^. CodeRowCode ==. val codeValue 109 | assert (rowCount == 1) (pure ()) 110 | 111 | convertCodeToToken :: CodeRecord -> DatabaseM TokenRecord 112 | convertCodeToToken code = do 113 | token <- secureRandom 114 | runQuery (invalidateCode code *> insertToken token code) 115 | 116 | createToken :: Code -> DatabaseM (Maybe TokenRecord) 117 | createToken code = do 118 | maybeCode <- findCode code 119 | case maybeCode of 120 | Nothing -> pure Nothing 121 | Just record -> do 122 | now <- liftIO getCurrentTime 123 | if isCodeValidAt record now then 124 | Just <$> convertCodeToToken record 125 | else pure Nothing 126 | 127 | createUser :: EmailAddress -> Text -> DatabaseM (Maybe User) 128 | createUser email name = do 129 | idUserMaybe <- runInsert userRow 130 | case idUserMaybe of 131 | Nothing -> pure Nothing 132 | Just idUser -> pure $ Just User { userID = asInt idUser 133 | , userEmail = email 134 | , userName = name 135 | } 136 | where 137 | userRow = UserRow { userRowName = name 138 | , userRowEmail = email 139 | } 140 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import ClassyPrelude 4 | import Control.Concurrent.Lifted 5 | import Control.Monad.Logger (runStderrLoggingT) 6 | import Data.CaseInsensitive (original) 7 | import Data.Char (isAlphaNum) 8 | import qualified Data.Configurator as Conf 9 | import Database 10 | import Mailer 11 | import Network.HTTP.Types 12 | import Network.Wai (Application) 13 | import qualified Network.Wai as Wai 14 | import qualified Network.Wai.Handler.Warp as Warp 15 | import Network.Wai.Handler.WebSockets (websocketsOr) 16 | import Network.WebSockets.Connection (defaultConnectionOptions) 17 | import Routes 18 | import qualified Sockets 19 | import System.Random (getStdRandom, randomR) 20 | import Web.Scotty 21 | 22 | maybeParam :: Parsable a => LText -> ActionM (Maybe a) 23 | maybeParam name = (Just <$> param name) `rescue` (pure . const Nothing) 24 | 25 | defaultParam :: Parsable a => LText -> a -> ActionM a 26 | defaultParam name def = param name `rescue` (pure . const def) 27 | 28 | validated :: Parsable a => (a -> Bool) -> LText -> ActionM a -> ActionM a 29 | validated f errorMessage val = do 30 | inner <- val 31 | if f inner then 32 | val 33 | else 34 | raise errorMessage 35 | 36 | maybeHeader :: HeaderName -> ActionM (Maybe Text) 37 | maybeHeader name = (listToMaybe . map (decodeUtf8 . snd) 38 | . filter ((== name) . fst) . Wai.requestHeaders) <$> request 39 | 40 | getHeader :: HeaderName -> ActionM Text 41 | getHeader name = maybe (raise message) pure =<< maybeHeader name 42 | where message = "missing \"" <> headerName <> "\" header" 43 | headerName = (fromStrict . decodeUtf8 . original) name 44 | 45 | route :: Database 46 | -> Chan (EmailAddress, Code) 47 | -> Chan ResolvedPost 48 | -> (ActionM () -> ScottyM ()) 49 | -> ActionM (Either Response Request) 50 | -> ScottyM () 51 | route db emailChan socketChan path makeReq = path $ do 52 | reqOrRes <- makeReq 53 | let dbRes = either pure execute reqOrRes 54 | res <- liftIO (runReaderT dbRes db) 55 | effects <- send res 56 | mapM_ (liftIO . perform) effects 57 | where 58 | perform :: SideEffect -> IO () 59 | perform (SendEmail emailAddress code) = 60 | writeChan emailChan (emailAddress, code) 61 | perform (SocketUpdate p) = 62 | writeChan socketChan p 63 | 64 | simpleRoute :: Database 65 | -> Chan (EmailAddress, Code) 66 | -> Chan ResolvedPost 67 | -> (ActionM () -> ScottyM ()) 68 | -> ActionM Request -> ScottyM () 69 | simpleRoute db emailChan socketChan path makeReq = route db emailChan socketChan path $ 70 | (Right <$> makeReq) `rescue` (pure . Left . BadRequest) 71 | 72 | execute :: Request -> DatabaseM Response 73 | execute (GetPost idPost) = maybe (PostNotFound idPost) ExistingPost <$> getPost idPost 74 | execute (ListPosts query) = PostList <$> getPosts query 75 | execute (CreatePost idParent token content) = 76 | maybe (pure BadToken) makePost =<< getUserByToken token 77 | where makePost user = do 78 | maybePost <- createPost user content idParent 79 | pure $ case (idParent, maybePost) of 80 | (_, Just post) -> NewPost post 81 | (Just idParent, Nothing) -> PostNotFound idParent 82 | (Nothing, Nothing) -> error "creating top-level posts should never fail" 83 | execute (CreateCode emailAddress) = 84 | maybe UnknownEmail NewCode <$> createCode emailAddress 85 | execute (CreateToken code) = 86 | maybe (pure BadCode) (fmap NewToken . withUser) =<< createToken code 87 | where 88 | noUser = error "we created a token but then couldn't find the user" 89 | withUser token@TokenRecord{tokenUserID} = 90 | maybe noUser (ResolvedToken token) <$> getUser tokenUserID 91 | execute (CreateUser email name) = 92 | maybe (pure ExistingNameOrEmail) withCode =<< createUser email name 93 | where withCode User{userEmail} = maybe noCode NewUser <$> createCode userEmail 94 | noCode = error "failed to create code for new user" 95 | 96 | data SideEffect = SendEmail EmailAddress Code 97 | | SocketUpdate ResolvedPost 98 | 99 | done :: ActionM [SideEffect] 100 | done = pure [] 101 | 102 | send :: Response -> ActionM [SideEffect] 103 | send (NewPost p) = json p $> [SocketUpdate p] 104 | send (ExistingPost p) = json p *> done 105 | send (PostList ps) = json ps *> done 106 | send (NewToken t) = json t *> done 107 | send (NewUser resolvedCode@(ResolvedCode _ user)) = json user *> send (NewCode resolvedCode) 108 | send (NewCode (ResolvedCode code user)) = pure [SendEmail (userEmail user) (codeValue code)] 109 | send BadToken = status status401 *> text "invalid token" *> done 110 | send BadCode = status status401 *> text "invalid code" *> done 111 | send UnknownEmail = status status200 *> done 112 | send InvalidUsername = status status400 *> text "invalid username" *> done 113 | send ExistingNameOrEmail = status status409 *> text "username or email address taken" *> done 114 | send (BadRequest message) = status status400 *> text message *> done 115 | send (PostNotFound idPost) = status status404 *> text message *> done 116 | where message = mconcat ["post ", tlshow idPost, " not found"] 117 | 118 | isLegalLimit :: Int -> Bool 119 | isLegalLimit x 120 | | x < 1 = False 121 | | x > 500 = False 122 | | otherwise = True 123 | 124 | basilica :: Maybe ByteString 125 | -> Database 126 | -> Chan (EmailAddress, Code) 127 | -> Chan ResolvedPost 128 | -> IO Application 129 | basilica origin db emailChan socketChan = scottyApp $ do 130 | case origin of 131 | Nothing -> pure () 132 | Just o -> do 133 | middleware (addHeaders [("Access-Control-Allow-Origin", o)]) 134 | addroute OPTIONS (function $ const $ Just []) $ do 135 | setHeader "Access-Control-Allow-Headers" "X-Token" 136 | setHeader "Access-Control-Allow-Methods" "GET, POST, PUT, PATCH, DELETE, OPTIONS" 137 | status status200 138 | 139 | let simple = simpleRoute db emailChan socketChan 140 | 141 | let limit = validated isLegalLimit "limit out of range" 142 | (defaultParam "limit" 200) 143 | simple (get "/posts") (ListPosts <$> (PostQuery <$> maybeParam "before" 144 | <*> maybeParam "after" 145 | <*> limit)) 146 | simple (get "/posts/:id") (GetPost <$> param "id") 147 | simple (post "/posts") (CreatePost Nothing <$> getHeader "X-Token" 148 | <*> param "content") 149 | simple (post "/posts/:id") (CreatePost <$> (Just <$> param "id") 150 | <*> getHeader "X-Token" 151 | <*> param "content") 152 | simple (post "/codes") (CreateCode <$> param "email") 153 | simple (post "/tokens") (CreateToken <$> param "code") 154 | 155 | route db emailChan socketChan (post "/users") $ do 156 | name <- param "name" 157 | if isValidName name then 158 | (fmap Right . CreateUser) <$> param "email" <*> pure name 159 | else 160 | pure (Left InvalidUsername) 161 | 162 | isValidName :: Text -> Bool 163 | isValidName name = all isAlphaNum name && (len >= 2) && (len < 20) 164 | where len = length name 165 | 166 | addHeaders :: ResponseHeaders -> Wai.Middleware 167 | addHeaders newHeaders app req respond = app req $ \response -> do 168 | let (st, currentHeaders, streamHandle) = Wai.responseToStream response 169 | streamHandle $ \streamBody -> 170 | respond $ Wai.responseStream st (currentHeaders ++ newHeaders) streamBody 171 | 172 | randomSubject :: IO Text 173 | randomSubject = (subjects `indexEx`) <$> getStdRandom (randomR (0, length subjects - 1)) 174 | where subjects = [ "Hey Beautiful" 175 | , "Hey Baby" 176 | , "Hey Hon" 177 | , "Hey Honey" 178 | , "Hey Girl" 179 | , "Hey Sugarlips" 180 | , "Hey Darling" 181 | , "Hey Buttercup" 182 | , "Hey Honeyfingers" 183 | , "Hey Syruptoes" 184 | ] 185 | 186 | sendCodeMail :: Mailer -> Text -> (EmailAddress, Code) -> IO () 187 | sendCodeMail mailer clientUrl (to, code) = do 188 | subject <- randomSubject 189 | sendMail mailer (easyEmail to subject messageBody) 190 | where messageBody = intercalate "\n" 191 | [ "Here's your Basilicode:" 192 | , "" 193 | , code 194 | , "" 195 | , "And a handy login link:" 196 | , "" 197 | , clientUrl <> "/login?code=" <> code 198 | , "" 199 | , "Love," 200 | , " Basilica" 201 | ] 202 | 203 | logCode :: (EmailAddress, Code) -> IO () 204 | logCode (to, code) = putStrLn (intercalate ": " [to, code]) 205 | 206 | main :: IO () 207 | main = do 208 | conf <- Conf.load [Conf.Required "conf"] 209 | port <- Conf.require conf "port" 210 | origin <- Conf.lookup conf "client-origin" 211 | mailgunKey <- Conf.lookup conf "mailgun-key" 212 | mailHandler <- case mailgunKey of 213 | Nothing -> pure logCode 214 | Just key -> sendCodeMail (newMailer key) <$> Conf.require conf "client-url" 215 | emailChan <- newChan 216 | socketChan <- newChan 217 | server <- Sockets.newServer socketChan 218 | _ <- fork $ getChanContents emailChan >>= mapM_ mailHandler 219 | 220 | dbPath <- Conf.require conf "dbpath" 221 | runStderrLoggingT $ withDatabase dbPath $ \db -> 222 | liftIO $ do 223 | api <- basilica origin db emailChan socketChan 224 | putStrLn $ "Running on port " ++ tshow port 225 | Warp.run port (websocketsOr defaultConnectionOptions server api) 226 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Basilica 2 | 3 | You can see a live demo running at https://basilica.horse, which currently hosts both [the API](https://basilica.horse/api/posts) and the [official Om client](https://github.com/ianthehenry/basilica-client). 4 | 5 | A basilica is like a forum, but for a few ill-defined differences. For more detail please consult the table below, adapted from a crude sketch I made while drunk. 6 | 7 | Forum | Basilica 8 | ----: | :------- 9 | PHP | Haskell 10 | 90s | 2010s 11 | trolls | friends 12 | "rich formatting" | markdown 13 | paging | lazy tree 14 | threads ↑ comments ↓ | uniform hierarchy 15 | `
` | HTTP API 16 | inline CSS | bots, webhooks, extensions 17 | F5 | websockets 18 | 19 | # Status 20 | 21 | Basilica is *usable*. It is not a comprehensive, beautiful piece of software, but it works and the canonical instance of it has been live and running since 2014. 22 | 23 | Further development is not very likely, since it works well enough for my purposes. 24 | 25 | # API 26 | 27 | ## Resources 28 | 29 | Basilica defines a few resources, which are always communicated in JSON. 30 | 31 | Sometimes the API will send *resolved* data, which means that it will turn: 32 | 33 | "idResource": 123 34 | 35 | Into: 36 | 37 | "resource": { "id": 123, ... } 38 | 39 | When it does so will be documented in the route response. 40 | 41 | Unless otherwise specified, no value will be `null`. 42 | 43 | ### Post 44 | 45 | ```json 46 | { "id": 49 47 | , "idParent": 14 48 | , "idUser": 43 49 | , "at": "2014-08-17T01:19:15.139Z" 50 | , "count": 0 51 | , "content": "any string" 52 | , "children": [] 53 | } 54 | ``` 55 | 56 | - `id` is a monotonically increasing identifier, and *it is the only field that should be used for sorting posts*. 57 | - `idParent` *can be `null`*. Root posts have no parents. 58 | - `idUser` is the `id` of the user who created the post. 59 | - `at` is a string representing the date that the post was created, in ISO 8601 format. This field exists to be displayed to the user; it should not be used for sorting or paging. Use `id` for that. 60 | - `count` is the *total number of children that this post has*, regardless of the number of children returned in any response. 61 | - `children` is a list of posts whose `idParent` is equal to this post's `id`. This is *not necessarily an exhaustive list*. Comparing the number of elements in this field to the `count` field can tell you if there are more children to load. 62 | - `children` will *always* be sorted by `id`, with newer posts (larger `id`s) in the front of the list 63 | 64 | ### User 65 | 66 | ```json 67 | { "id": 32 68 | , "email": "name@example.com" 69 | , "name": "ian" 70 | , "face": {} 71 | } 72 | ``` 73 | 74 | - `email` will be omitted unless otherwise specified in the route documentation 75 | - `face` is an object that indicates how to render a thumbnail of the user. Currently the only valid options are: 76 | - `{ "gravatar": "a130ced3f36ffd4604f4dae04b2b3bcd" }` 77 | - `{ "string": "☃" }` 78 | - **not implemented** 79 | 80 | ### Code 81 | 82 | Codes are never communicated via JSON, so it doesn't make sense to show their format. Publicly, they can be considered strings. They happen to currently be hexadecimal strings, but that's an implementation detail that may change. 83 | 84 | ### Token 85 | 86 | ```json 87 | { "id": 91 88 | , "token": "a long string" 89 | , "idUser": 32 90 | } 91 | ``` 92 | 93 | ## Authentication 94 | 95 | There's a goofy hand-rolled auth scheme. 96 | 97 | There are no passwords. Authentication is done purely through email. The process looks this: 98 | 99 | - request a code (see `POST /codes`) 100 | - Basilica emails it to you 101 | - you trade in the code for a token (see `POST /tokens`) 102 | - you use that token to authenticate all future requests (by setting the `X-Token` header) 103 | 104 | I'm gonna repeat that last thing because it's important: you need to set an `X-Token` header to make an authenticated request. No cookies, query parameters, nothing like that. That header is the only thing that counts. 105 | 106 | This is similar to the "forgot my password" flow found in most apps, except that you don't have to pretend to remember anything. 107 | 108 | ## Routes 109 | 110 | ### Postal Routes 111 | 112 | #### `POST /posts/:idParent` 113 | 114 | - **requires a valid `token`** 115 | - for: creating a new post as a child of the specified `idParent` 116 | - `idParent` is optional. If omitted, this will create a post with `idParent` set to `null`. 117 | - arguments: an `x-www-form-urlencoded` body is expected with 118 | - `content` (any string) 119 | - required 120 | - must not be the empty string 121 | - response: the newly created post, JSON-encoded 122 | - `idUser` will be resolved 123 | - if the post has a `count` other than `0`, that's a bug 124 | - the post will not have `children` 125 | 126 | ```sh 127 | $ curl -i # show response headers (otherwise a 401 is very confusing) 128 | -X POST # set the HTTP verb 129 | --data "content=hello%20world" # escape your string! 130 | -H "X-Token: asdf" # requires authentication 131 | "http://localhost:3000/posts" # the actual route 132 | ``` 133 | 134 | #### `GET /posts/:id` 135 | 136 | - for: loading posts and post children 137 | - arguments: query parameters 138 | - `depth`: how deeply to recursively load `children` 139 | - **not implemented** 140 | - default: `1` 141 | - if `0`, the response will not include `children` at all 142 | - valid values: just `0` and `1` right now 143 | - `after`: the `id` of a post 144 | - **not implemented** 145 | - optional 146 | - ignored if `depth` is `0` 147 | - the response will not include any posts created before this in the `children` list (recursively, if multiple depths are ever supported) 148 | - `limit`: the maximum number of `children` to load 149 | - **not implemented** 150 | - default: `50` 151 | - ignored if `depth` is `0` 152 | - valid values: `1` to `500` 153 | - applies recursively, if multiple depths are ever supported 154 | - response: a JSON-encoded post 155 | - if `depth` is greater than `0`, it will include `children` 156 | - `idUser` will be resolved for the root post and all children, recursively 157 | - remember that `count` is always the *total* number of children, regardless of the `limit` 158 | 159 | #### `GET /posts` 160 | 161 | - for: loading every single post in the entire database, catching up after a disconnect (with `after`) 162 | - arguments: query parameters 163 | - `after`: the `id` of a post 164 | - optional 165 | - the response will only contain posts created after the specified post 166 | - `before`: the `id` of a post 167 | - optional 168 | - the response will only contain posts created before the specified post 169 | - `limit`: the maximum number of posts to return 170 | - default: `200` 171 | - valid values: `1` to `500` 172 | - response: 173 | - if `after` is specified, and there were more than `limit` posts to return, this returns... some error code. I'm not sure what though. `410`, maybe? 174 | - **not implemented** 175 | - otherwise, a JSON array of posts with no `children` fields, sorted by `id` from newest to oldest 176 | - `idUser` will be resolved 177 | 178 | ### User Routes 179 | 180 | #### `POST /users` 181 | 182 | - for: signing up for a new account 183 | - arguments: `x-www-form-urlencoded` 184 | - `email`: the email address for the user. 185 | - `name`: the username. Must contain only alphanumeric characters. 186 | - response: 187 | - `200` with the newly created `user` 188 | - `400` if the username contains non-alphanumeric characters 189 | - `409` if an account already exists with the specified username or email address, with no response body 190 | - side effect: automatically invokes `POST /codes` with the given email address 191 | 192 | ### Auth Routes 193 | 194 | #### `POST /codes` 195 | 196 | - for: creating a new code, which can be used to obtain a token 197 | - arguments: `x-www-form-urlencoded` 198 | - `email`: the email address of the user for which you would like to create a code 199 | - response: this route will always return an empty response body with a `200` status code, regardless of whether `email` corresponds to a valid email address 200 | - a timing attack can absolutely be used to determine if the email corresponds to a valid account or not; knock yourself out 201 | - side effect: if the email address specified matches a user account, Basilica will send an email containing the newly created code. 202 | 203 | #### `DELETE /codes/:code` 204 | 205 | - for: revoking a code, in case it was sent in error 206 | - **not implemented** 207 | - or documented 208 | 209 | #### `POST /tokens` 210 | 211 | - for: creating a new token 212 | - arguments: `x-www-form-urlencoded` 213 | - `code`: a code obtained from a call to `POST /codes` 214 | - required 215 | - note: auth tokens don't do anything yet 216 | - response: 217 | - if the code is valid, a JSON-encoded token with `idUser` resolved into `user` 218 | - otherwise, `401` 219 | - side effect: invalidates the code specified 220 | 221 | #### `GET /tokens` 222 | 223 | - for: listing tokens 224 | - response: an array of JSON-encoded token objects with only `id` specified 225 | - probably other stuff later 226 | - **not implemented** 227 | 228 | #### `DELETE /tokens/:id` 229 | 230 | - for: revoking a token ("logging out") 231 | - arguments: 232 | - `id`: the `id` of the token to revoke 233 | - required 234 | - response: `200`, `404`, or `401` 235 | - **not implemented** 236 | 237 | # Websockets 238 | 239 | There is currently one websocket route, a single firehose stream of all new posts created, in JSON, with `idUser` resolved. The route is just `/`, with the `ws` or `wss` protocol. 240 | 241 | When connected, Basilica will periodically send ping frames. If the client doesn't respond in a timely manner, that client will be closed with either a friendly or slightly hostile message. 242 | 243 | Currently this is set to ping every 20 seconds and to disconnect clients if more than 40 seconds passes without receiving a pong. Don't rely on those values, though. Just pong the pings as quickly as you can. All websocket libraries should do this for you automatically. 244 | 245 | ## Client Implementation Notes 246 | 247 | - When a new post is created, clients should update their cached `count` value for its parent. It's important that this value stays up-to-date for accurate paging. 248 | - When a disconnect occurs, and it will, reconnect the socket and then call `GET /posts?after=id`, where `id` is the latest post that you knew about. It's important that you reconnect the socket before filling the gap, otherwise any post created in the brief moment after the response and before the socket comes back will be lost. 249 | 250 | ## Basiliclients 251 | 252 | - The official [browser client](https://github.com/ianthehenry/basilica-client), with some implemented features. 253 | 254 | # Development 255 | 256 | Basilica uses SQLite. You need to create the database. 257 | 258 | $ sqlite3 basilica.db ".read schema.sql" 259 | 260 | Basilica is developed using [`stack`](http://haskellstack.org): 261 | 262 | $ stack build 263 | 264 | After that you can modify the `conf` file. Here's a list of all keys and their meanings: 265 | 266 | port = 3000 267 | dbpath = "basilica.db" 268 | client-origin = "http://localhost:3333" 269 | client-url = "http://localhost:3333/client/" 270 | mailgun-key = "asdf" 271 | 272 | - `port` is the port that the HTTP and WS server will run on. 273 | - `dbpath` is the path to the SQLite file that you've initialized with the schema. 274 | - `client-origin` is optional. When specified, it will set the `Access-Control-Allow-Origin` header and respond to `OPTIONS` requests appropriately. This is especially useful for development when you might be serving the client from a different local port. 275 | - `client-url` is used in emails to generate one-click login links. 276 | - `mailgun-key` is the API key for the [Mailgun](https://www.mailgun.com) account you want to use to send emails. If omitted, codes will be written to stdout. 277 | 278 | Then you can run it. 279 | 280 | $ stack exec basilica 281 | 282 | Now you're ready to *basilicate*. 283 | 284 | ## Contributors 285 | 286 | - [Ian](https://github.com/ianthehenry) started it 287 | - [Hao](https://github.com/hlian) made websockets shinier 288 | --------------------------------------------------------------------------------