2 files changed, 67 insertions(+), 36 deletions(-)

M app/Main.hs
M gemini-textboard.cabal

@@ 15,6 15,7 @@ import Network.URI (parseRelativeReference)
 
 import Data.Functor (($>))
 import Data.Foldable (asum)
+import Data.Traversable (for)
 import Data.Maybe (fromJust)
 import Data.List (intercalate)
 


@@ 29,6 30,9 @@ import System.Clock (TimeSpec(TimeSpec))
 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,9 40,18 @@ data Context = Context
   , 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)
 


@@ 54,7 67,7 @@ main = do
         cleanNonceCache
   _ <- forkIO cleanNonceCache
   let ctx = Context conn nonceGen nonceCache
-  runServer Nothing "1964" $ runRouteT' (`runReaderT` ctx) app
+  runServer Nothing "1965" "cert.pem" $ runRouteT' (`runReaderT` ctx) app
 
 -- DB stuff
 -----------


@@ 63,55 76,58 @@ createTables :: SQL.Connection -> IO ()
 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 @@ validateNonce nonce = do
   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
 -----------
 


@@ 149,43 177,45 @@ homepageHandler = do
     , 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


@@ 211,4 241,3 @@ postHandler nonce content = do
 headMaybe :: [a] -> Maybe a
 headMaybe (a:_) = Just a
 headMaybe []    = Nothing
-

@@ 22,8 22,8 @@ executable gemini-textboard
   main-is:             Main.hs
   other-extensions:    OverloadedStrings
   build-depends:       base ^>=4.12.0.0 || ^>=4.13.0.0 || ^>=4.14.0.0
-                     , gemini-server ^>=0.1.0.0
-                     , gemini-router ^>=0.1.0.0
+                     , gemini-server ^>=0.2.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 33,9 @@ executable gemini-textboard
                      , 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
-