gemini-textboard 0.1.0.0 → 0.2.0.1
raw patch · 4 files changed
+91/−39 lines, 4 filesdep +HsOpenSSLdep +base64dep +cryptohash-sha256dep ~basedep ~gemini-routerdep ~gemini-server
Dependencies added: HsOpenSSL, base64, cryptohash-sha256
Dependency ranges changed: base, gemini-router, gemini-server, text, time, transformers
Files
- CHANGELOG.md +11/−1
- README.md +2/−0
- app/Main.hs +69/−32
- gemini-textboard.cabal +9/−6
CHANGELOG.md view
@@ -1,6 +1,16 @@ # Revision history for gemini-textboard +## 0.2.0.1 -- 2021-03-19++* Update gemini-server dependency (TLS resumption fix)++## 0.2.0.0 -- 2021-02-22++* SSL/TLS+ - stunnel is no longer necessary+ - when present, the client certificate is used to derive a hash pseudonym+ (similar to tripcodes in classic boards)+ ## 0.1.0.0 -- 2020-07-24 * First version. Released on an unsuspecting world.-
README.md view
@@ -8,3 +8,5 @@ This package serves also as an example for the other haskell-gemini libraries. More info at https://sr.ht/~fgaz/haskell-gemini/ +**I have an instance online at [gemini-textboard.fgaz.me](gemini://gemini-textboard.fgaz.me)**+
app/Main.hs view
@@ -15,6 +15,7 @@ import Data.Functor (($>)) import Data.Foldable (asum)+import Data.Traversable (for) import Data.Maybe (fromJust) import Data.List (intercalate) @@ -29,6 +30,9 @@ import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Time.Format (formatTime, defaultTimeLocale, rfc822DateFormat) import qualified Crypto.Nonce as Nonce+import Data.ByteString.Base64.URL (encodeBase64Unpadded)+import OpenSSL.X509 (writeDerX509)+import Crypto.Hash.SHA256 (hashlazy) data Context = Context@@ -36,10 +40,19 @@ , gen :: Nonce.Generator , cache :: Cache.Cache Text PostType } -type ThreadId = Int+type PostId = Int -data PostType = New | Reply ThreadId+data PostType = New | Reply PostId +data Post = Post+ { postId :: PostId+ , postContent :: Text+ , postAuthor :: Maybe Text+ , postTime :: UTCTime }++instance SQL.FromRow Post where+ fromRow = Post <$> SQL.field <*> SQL.field <*> SQL.field <*> SQL.field+ type App = RouteT (ReaderT Context IO) main :: IO ()@@ -54,7 +67,7 @@ cleanNonceCache _ <- forkIO cleanNonceCache let ctx = Context conn nonceGen nonceCache- runServer Nothing "1964" $ runRouteT' (`runReaderT` ctx) app+ runServer Nothing "1965" "cert.pem" "cert.pem" $ runRouteT' (`runReaderT` ctx) app -- DB stuff -----------@@ -63,55 +76,58 @@ createTables conn = do SQL.execute_ conn $ "CREATE TABLE IF NOT EXISTS posts " <> "(id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, " <>- "parent INTEGER, content TEXT NOT NULL, time TEXT NOT NULL, " <>+ "parent INTEGER, content TEXT NOT NULL, author TEXT, time TEXT NOT NULL, " <> "FOREIGN KEY(parent) REFERENCES posts(id))" SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS post_id_index ON posts (id)" SQL.execute_ conn "CREATE INDEX IF NOT EXISTS post_parent_index ON posts (parent)" SQL.execute_ conn "CREATE INDEX IF NOT EXISTS post_time_index ON posts (time)" -getAllThreads :: App [(Int, Text, UTCTime, Maybe (Int, Text, UTCTime))]+getAllThreads :: App [(Post, Maybe Post)] getAllThreads = do conn <- db <$> lift ask results <- liftIO $ SQL.query_ conn- "SELECT p.id, p.content, p.time, r.id, r.content, r.time \+ "SELECT p.id, p.content, p.author, p.time, r.id, r.content, r.author, r.time \ \ FROM\ \ posts AS p\ \ OUTER LEFT JOIN (SELECT *, max(time) FROM posts GROUP BY parent) AS r\ \ ON p.id = r.parent\ \ WHERE p.parent IS NULL\ \ ORDER BY IFNULL(r.time, p.time) DESC"- pure $ fmap groupLast results- where groupLast (opId, opTxt, opTime, lastId, lastTxt, lastTime) =- (opId, opTxt, opTime, (,,) <$> lastId <*> lastTxt <*> lastTime)+ pure $ fmap mkPosts results+ where mkPosts (opId, opTxt, opAuthor, opTime, lastId, lastTxt, lastAuthor, lastTime) =+ (Post opId opTxt opAuthor opTime, Post <$> lastId <*> lastTxt <*> Just lastAuthor <*> lastTime) -getThread :: ThreadId -> App (Maybe (Text, UTCTime))+getThread :: PostId -> App (Maybe Post) getThread threadId = do conn <- db <$> lift ask liftIO $ headMaybe <$> SQL.query conn- "SELECT content, time FROM posts WHERE id = ? AND parent IS NULL" (SQL.Only threadId)+ "SELECT id, content, author, time FROM posts WHERE id = ? AND parent IS NULL" (SQL.Only threadId) -getReplies :: ThreadId -> App [(Int, Text, UTCTime)]+getReplies :: PostId -> App [Post] getReplies threadId = do conn <- db <$> lift ask liftIO $ SQL.query conn- "SELECT id, content, time FROM posts WHERE parent = ?" (SQL.Only threadId)+ "SELECT id, content, author, time FROM posts WHERE parent = ?" (SQL.Only threadId) -insertThread :: String -> App ThreadId+insertThread :: String -> App PostId insertThread content = do conn <- db <$> lift ask now <- liftIO getCurrentTime+ author <- getAuthor liftIO $ SQL.execute conn- "INSERT INTO posts (parent, content, time) VALUES (NULL,?,?)" (content, now)+ "INSERT INTO posts (parent, content, author, time) VALUES (NULL,?,?,?)"+ (content, author, now) fmap fromIntegral $ liftIO $ SQL.lastInsertRowId conn --TODO non thread safe? -insertReply :: ThreadId -> String -> App ()+insertReply :: PostId -> String -> App () insertReply threadId content = do conn <- db <$> lift ask now <- liftIO getCurrentTime+ author <- getAuthor liftIO $ SQL.execute conn- "INSERT INTO posts (parent, content, time) VALUES (?,?,?)"- (threadId, content, now)+ "INSERT INTO posts (parent, content, author, time) VALUES (?,?,?,?)"+ (threadId, content, author, now) -- Nonce stuff --------------@@ -128,6 +144,18 @@ ctx <- lift ask liftIO $ Cache.lookup (cache ctx) nonce +-- Obtaining an author id+-------------------------++getAuthor :: App (Maybe Text)+getAuthor = do+ maybeCert <- requestCert <$> getRequest+ for maybeCert $ \c -> do+ -- Huge hack, but it works reasonably well.+ -- Ideally one should only hash the pk parameters.+ der <- liftIO $ writeDerX509 c+ pure $ encodeBase64Unpadded $ hashlazy der+ -- Handlers ----------- @@ -138,6 +166,7 @@ , dir "thread" $ capture $ \threadId -> end $ threadHandler threadId , dir "thread" $ capture $ \threadId -> dir "post" $ end $ threadPostRedirectHandler threadId , dir "p" $ capture $ \nonce -> input "Write your post" $ \post -> end $ postHandler nonce post+ , dir "robots.txt" $ end robotsTxt ] homepageHandler :: App Response@@ -149,43 +178,45 @@ , LText "" ] <> intercalate [LText ""] (renderThread <$> threads) -renderThread :: ( ThreadId, T.Text, UTCTime- , Maybe (Int, T.Text, UTCTime) ) -> GeminiDocument-renderThread (i, txt, t, lastReply) =- renderOp (i, txt, t) <>+renderThread :: (Post, Maybe Post) -> GeminiDocument+renderThread (op, lastReply) =+ renderOp op <> [LText "⋮"] <> maybe [LText "No replies yet"] renderReply lastReply <>- [LLink (LT.pack $ "/thread/" <> show i) $ Just "Go to thread"]+ [LLink (LT.pack $ "/thread/" <> show (postId op)) $ Just "Go to thread"] threadHandler :: String -> App Response threadHandler threadId' = do let threadId = read threadId' :: Int --TODO better parsing --TODO check existence- Just (op, opTime) <- getThread threadId+ Just op <- getThread threadId replies <- getReplies threadId pure $ okGemini $ encodeUtf8 $ encodeGemini $ [ LH1 "Gemini Textboard" , LLink "/" $ Just "Back to thread list" , LText ""- ] <> renderOp (threadId, op, opTime) <> [LText ""] <>+ ] <> renderOp op <> [LText ""] <> intercalate [LText ""] (renderReply <$> replies) <> [LText "", LLink ("/thread/" <> LT.pack (show threadId) <> "/post") $ Just "New reply"] -renderOp :: (ThreadId, T.Text, UTCTime) -> GeminiDocument-renderOp (i, txt, t) =+renderOp :: Post -> GeminiDocument+renderOp (Post i txt author t) = [ LH2 $ "#" <> LT.pack (show i) <>- " - Anonymous - " <> --TODO use client cert for "tripcode"+ " - " <> renderAuthor author <> " - " <> LT.pack (formatTime defaultTimeLocale rfc822DateFormat t) , LText $ LT.fromStrict txt ] -renderReply :: (Int, T.Text, UTCTime) -> GeminiDocument-renderReply (i, txt, t) =+renderReply :: Post -> GeminiDocument+renderReply (Post i txt author t) = [ LH3 $ "#" <> LT.pack (show i) <>- " - Anonymous - " <> --TODO use client cert for "tripcode"+ " - " <> renderAuthor author <> " - " <> LT.pack (formatTime defaultTimeLocale rfc822DateFormat t) , LText $ LT.fromStrict txt ] +renderAuthor :: Maybe Text -> LT.Text+renderAuthor = maybe "Anonymous" LT.fromStrict+ threadPostRedirectHandler :: String -> App Response threadPostRedirectHandler threadId' = do let threadId = read threadId' --TODO better parsing --TODO check existence@@ -205,10 +236,16 @@ Reply threadId -> insertReply threadId content $> threadId pure $ redirect $ fromJust $ parseRelativeReference $ "/thread/" <> show threadId +robotsTxt :: App Response+robotsTxt = pure $ okGemini $ encodeUtf8+ "User-agent: *\n\+ \# Do not crawl submission pages\n\+ \Disallow: /post/\n\+ \Disallow: /p/"+ -- Utils -------- headMaybe :: [a] -> Maybe a headMaybe (a:_) = Just a headMaybe [] = Nothing-
gemini-textboard.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.2 name: gemini-textboard-version: 0.1.0.0+version: 0.2.0.1 synopsis: A barebones textboard for the Gemini protocol -- description: homepage: https://sr.ht/~fgaz/haskell-gemini/@@ -21,9 +21,10 @@ executable gemini-textboard main-is: Main.hs other-extensions: OverloadedStrings- build-depends: base ^>=4.13.0.0 || ^>=4.14.0.0- , gemini-server ^>=0.1.0.0- , gemini-router ^>=0.1.0.0+ build-depends: base ^>=4.12.0.0 || ^>=4.13.0.0 || ^>=4.14.0.0+ -- blocked on sqlite-simple || ^>=4.15.0.0+ , gemini-server ^>=0.3.0.0+ , gemini-router ^>=0.1.1.0 , language-gemini ^>=0.1.0.0 , nonce ^>=1.0.7 , cache ^>=0.1.3.0@@ -33,7 +34,9 @@ , time ^>=1.9.3 || ^>=1.10 , network-uri ^>=2.6.3.0 || ^>=2.7.0.0 , transformers ^>=0.5.6.2+ , cryptohash-sha256 ^>=0.11.102+ , base64 ^>=0.4.2+ , HsOpenSSL ^>=0.11.5.1 hs-source-dirs: app- ghc-options: -Wall+ ghc-options: -Wall -threaded default-language: Haskell2010-