Switch to text, add code for basic auth checking

Pastecan.cabal

@@ -29,6 +29,9 @@ executable pastecan
                      , containers
                      , string-conversions
                      , monad-logger
+                     , pwstore-fast
+                     , text
+                     , bytestring
   default-language:    Haskell2010
   other-modules:       Model
                      , API

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)

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
 |]