From e2e99002571d3f8cd9afdd55cc3c18ce793b6ad0 Mon Sep 17 00:00:00 2001
From: osmarks <osmarks@protonmail.com>
Date: Sun, 17 Sep 2017 19:31:56 +0100
Subject: [PATCH] Switch to text, add code for basic auth checking

---
 Pastecan.cabal |  3 +++
 src/API.hs     | 37 ++++++++++++++++++++++++++++++-------
 src/Model.hs   | 12 ++++++++----
 3 files changed, 41 insertions(+), 11 deletions(-)

diff --git a/Pastecan.cabal b/Pastecan.cabal
index 43e8b2c..f83462e 100644
--- a/Pastecan.cabal
+++ b/Pastecan.cabal
@@ -29,6 +29,9 @@ executable pastecan
                      , containers
                      , string-conversions
                      , monad-logger
+                     , pwstore-fast
+                     , text
+                     , bytestring
   default-language:    Haskell2010
   other-modules:       Model
                      , API
diff --git a/src/API.hs b/src/API.hs
index 1327c39..2358f85 100644
--- a/src/API.hs
+++ b/src/API.hs
@@ -6,17 +6,22 @@ module API where
 import Servant
 import Control.Monad.Except
 import Database.Persist.Sqlite
-import Data.String.Conversions
 import Control.Monad.Logger
 
+import Crypto.PasswordStore
+
+import qualified Data.Text as T
+import Data.Text (Text(..))
+import Data.Text.Encoding
+
 import Network.Wai.Handler.Warp as Warp
 
 import Model
 import Config
 
 type GetPasteAPI = 
-          Capture "username" String :> Capture "pasteName" String :> Get '[JSON] Paste
-    :<|> "raw" :> Capture "username" String :> Capture "pasteName" String :> Get '[PlainText] String
+          Capture "username" Text :> Capture "pasteName" Text :> Get '[JSON] Paste
+    :<|> "raw" :> Capture "username" Text :> Capture "pasteName" Text :> Get '[PlainText] Text
 
 type API = GetPasteAPI
 
@@ -33,15 +38,33 @@ justOrError e m =
 justOr404 :: App (Maybe a) -> App a
 justOr404 = justOrError err404
 
-getPasteData :: String -> String -> App Paste
+basicAuthCheck :: HandlerConfig -> BasicAuthCheck User
+basicAuthCheck HandlerConfig{db = db} =
+    BasicAuthCheck check
+        where
+            check :: BasicAuthData -> IO (BasicAuthResult User)
+            check (BasicAuthData username suppliedPassword) = do
+                -- Annoyingly, we can't use the App monad here.
+                userEntity <- flip runSqlPool db $ getBy $ Username (decodeUtf8 username)
+                case userEntity of
+                    Just (Entity _ userData) -> do
+                        let correctPassword = encodeUtf8 $ userPassword userData
+                        
+                        if verifyPassword suppliedPassword correctPassword then
+                            return $ Authorized userData
+                        else
+                            return BadPassword
+                    Nothing -> return NoSuchUser
+
+getPasteData :: Text -> Text -> App Paste
 getPasteData username name = do
     userEntity <- justOr404 $ runDB $ getBy $ Username username
     let (Entity uid _) = userEntity
-    pasteEntity <- justOr404 $ runDB $ selectFirst [PasteParent ==. uid, PasteName ==. name] []
+    pasteEntity <- justOr404 $ runDB $ getBy (PasteNamePoster name uid)
     let (Entity _ paste) = pasteEntity
     return paste
 
-getPasteRaw :: String -> String -> App String
+getPasteRaw :: Text -> Text -> App Text
 getPasteRaw u n = pasteContent <$> getPasteData u n
 
 server :: HandlerConfig -> Server API
@@ -52,7 +75,7 @@ proxy = Proxy
 
 mkApp :: FilePath -> IO Application
 mkApp path = do
-    pool <- runStderrLoggingT $ createSqlitePool (cs path) 5
+    pool <- runStderrLoggingT $ createSqlitePool (T.pack path) 5
     runSqlPool doMigrations pool
     let cfg = HandlerConfig pool
     return $ serve proxy (server cfg)
diff --git a/src/Model.hs b/src/Model.hs
index ee08b8e..71644c7 100644
--- a/src/Model.hs
+++ b/src/Model.hs
@@ -16,20 +16,24 @@ import GHC.Generics
 import Database.Persist
 import Database.Persist.Sql
 import Database.Persist.TH
+import qualified Data.Text as T
+import Data.Text (Text(..))
 
 import PasteType
 
 share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
 User json
-    username String
+    username Text
+    password Text
     Username username
     deriving Show Generic
 
 Paste json
-    parent UserId
-    name String
-    content String
+    poster UserId
+    name Text
+    content Text
     type PasteType
+    PasteNamePoster name poster
     deriving Show Generic
 |]