Halogen5

README.md

@@ -4,6 +4,26 @@
 
 Development Servers:
 
+to set up development, run
+
+```
+# install stack
+curl -sSL https://get.haskellstack.org/ | sh
+#install postgres + development deps
+sudo apt-get install postgresql python-psycopg2 libpq-dev inotify-tools
+## or the equivalent in brew
+# install spago purescript + parcel
+npm install -g spago purescript parcel
+
+stack install yesod yesod-bin
+
+# set up postgres
+sudo -u postgres psql
+CREATE DATABASE hastock;
+CREATE USER hastock WITH ENCRYPTED PASSWORD 'password';
+GRANT ALL PRIVILEGES ON DATABASE hastock TO hastock;
+```
+
 running `./hastock/stack exec -- yesod devel` will start a development server for the backend.
 
 running `./public/npm start` will start a hot reloading front end server - right now the new component is mounted below the old one - this will be addressed soon.

hastock workspace.code-workspace

@@ -0,0 +1,11 @@
+{
+	"folders": [
+		{
+			"path": "."
+		},
+		{
+			"path": "public"
+		}
+	],
+  "settings": {}
+}

hastock/config/routes

@@ -11,5 +11,5 @@
 /api/v1/stocks/#Text       QuoteR GET
 /api/v1/register           RegisterR POST
 /api/v1/login              LoginR POST
-/api/v1/user/#Text         UserR GET
+/api/v1/user         UserR GET
 

hastock/config/settings.yml

@@ -32,3 +32,5 @@ dbPassword: '_env:PGPASS:password'
 
 copyright: Insert copyright statement here
 #analytics: UA-YOURCODE
+# jwt secret
+jwtSecret: '_env:JWT_SECRET:C4YPT0G4APHY'

hastock/package.yaml

@@ -1,5 +1,5 @@
 name: hastock
-version: "0.0.0"
+version: '0.0.0'
 
 dependencies:
   # Due to a bug in GHC 8.0.1, we block its usage
@@ -13,6 +13,7 @@ dependencies:
   - persistent >= 0.3.1
   - persistent-template
   - persistent-postgresql
+  - postgresql-simple
   - data-serializer
   - http-types
   - jwt == 0.7.2

hastock/src/Application.hs

@@ -42,7 +42,7 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger),
 import Network.Wai.Middleware.Rewrite       (rewritePureWithQueries, 
                                              PathsAndQueries)
 import Network.Wai.Middleware.Routed        (routedMiddleware)
-import Network.Wai.Middleware.Cors          (simpleCors)
+import Network.Wai.Middleware.Cors          (simpleCors, CorsResourcePolicy(..), simpleCorsResourcePolicy, simpleHeaders, cors)
 import Network.HTTP.Types.Header            (RequestHeaders)
 import System.Log.FastLogger                (defaultBufSize, newStdoutLoggerSet,
                                              toLogStr)
@@ -53,6 +53,7 @@ import Handler.Common
 import Handler.Home
 import Database.Persist.Postgresql (ConnectionString)
 import Model.User
+import Network.HTTP.Types.Method (methodGet, methodPost, methodPut, methodDelete)
 
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
@@ -107,7 +108,9 @@ makeApplication foundation = do
     logWare <- makeLogWare foundation
     -- Create the WAI application and apply middlewares
     appPlain <- toWaiAppPlain foundation
-    return $ makeSpaRoutes . simpleCors . logWare $ defaultMiddlewaresNoLogging appPlain
+    return $ makeSpaRoutes . corsMiddleware . logWare $ defaultMiddlewaresNoLogging appPlain
+    where 
+      corsMiddleware = cors . const . Just $ simpleCorsResourcePolicy { corsRequestHeaders = simpleHeaders ++ ["authorization"], corsOrigins = Nothing, corsMethods = [methodGet, methodPost, methodPut, methodDelete] }
 
 -- TODO: possibly publish this as a helper middleware
 makeSpaRoutes :: Middleware

hastock/src/Handler/Home.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE MultiParamTypeClasses  #-}
 {-# LANGUAGE TypeFamilies           #-}
 {-# LANGUAGE DataKinds              #-}
-
+{-# LANGUAGE TypeApplications #-}
 module Handler.Home where
 
 import           Import
@@ -16,12 +16,15 @@ import           Database.Persist.Sql           ( fromSqlKey
                                                 )
 import qualified Data.Text                     as T
 import           Data.Char
+import qualified Data.List                     as L
 import qualified Data.Map                      as Map
-import           Yesod.Auth.Util.PasswordStore  ( makePassword, verifyPassword )
+import           Yesod.Auth.Util.PasswordStore  ( makePassword
+                                                , verifyPassword
+                                                )
 import qualified Web.JWT                       as JWT
-
-mySecret :: JWT.Secret
-mySecret = JWT.secret "hello"
+import           Database.PostgreSQL.Simple     ( SqlError(..) )
+import qualified Network.Wai                   as WAI
+import qualified Network.Wai.Internal          as WAIINT
 
 getHomeR :: Handler ()
 getHomeR = sendFile "text/html" "static/index.html"
@@ -40,74 +43,114 @@ error404 :: Status
 error404 = Status 404 "client not found"
 
 resultToMaybe :: Result a -> Maybe a
-resultToMaybe (Error _) = Nothing
+resultToMaybe (Error   _    ) = Nothing
 resultToMaybe (Success value) = Just value
 
 makeJWTClaimsSet :: Key User -> JWT.JWTClaimsSet
 makeJWTClaimsSet dbEntity = JWT.def
-          { JWT.unregisteredClaims =
-            Map.fromList [("id", String . tshow . fromSqlKey $ dbEntity)]
-          }
+  { JWT.unregisteredClaims = Map.fromList
+                               [("id", String . tshow . fromSqlKey $ dbEntity)]
+  }
 
-getIdFromJWT :: Text -> Maybe Int64
-getIdFromJWT jwt = do 
-  parsedJWT <- JWT.decodeAndVerifySignature mySecret jwt
+getIdFromJWT :: Text -> Text -> Maybe Int64
+getIdFromJWT jwt secret = do
+  parsedJWT       <- JWT.decodeAndVerifySignature (JWT.secret secret) jwt
   dbRecordKeyJSON <- lookup "id" . JWT.unregisteredClaims $ JWT.claims parsedJWT
-  dbRecordKey <- resultToMaybe . fromJSON $ dbRecordKeyJSON
+  dbRecordKey     <- resultToMaybe . fromJSON $ dbRecordKeyJSON
   readIntegral dbRecordKey
 
-getUserR :: Text -> HandlerFor App Value
-getUserR jwt = 
-      case getIdFromJWT jwt of
-        Nothing -> sendResponseStatus error500 ("error parsing credentials, please try logging in" :: T.Text)
-        Just parsedId -> do
-          userEntity <- runDB $ do
-            get (toSqlKey parsedId :: Key User)
-          case userEntity of
-              Nothing -> sendResponseStatus error404 ("invalid credentials, please try logging in" :: T.Text)
-              Just user -> return $ toJSON user
+as :: a -> a
+as x = x
+
+getUserR :: HandlerFor App Value
+getUserR = do
+  app <- getYesod
+  req <- waiRequest
+  let headers  = WAI.requestHeaders req
+      getJWTId = flip getIdFromJWT (jwtSecret $ appSettings app)
+      mayJWT   = drop 7 . decodeUtf8 <$> L.lookup "authorization" headers
+  jwt <- errorIfNothing "Token not provided" mayJWT
+  parsedId <- errorIfNothing "error parsing credentials, please try logging in" (getJWTId jwt)
+  mayUserEntity <- runDB (get $ toSqlKey parsedId)
+  user <- errorIfNothing "invalid credentials, please try logging in" mayUserEntity
+  return $ buildResponseJson jwt user
+
 
+errorIfNothing :: MonadHandler m => Text -> Maybe a -> m a
+errorIfNothing eText = maybe (sendResponseStatus error500 eText) pure
 
+buildResponseJson :: -> Text -> User -> Value
+buildResponseJson jwt user = toJSON UserResponse 
+  { userResponseName = getUserName user
+  , userResponseToken = jwt
+  }
 
 postLoginR :: HandlerFor App Value
 postLoginR = do
+  app  <- getYesod
   body <- requireCheckJsonBody :: Handler Value
   case (fromJSON body :: Result LoginInfo) of
-    Error s               ->  sendResponseStatus error500 $ toJSON s
-    Success loginDetails  ->  runDB $ do
+    Error   s            -> sendResponseStatus error500 $ toJSON s
+    Success loginDetails -> runDB $ do
       userRecord <- getBy $ UniqueEmail $ loginEmail loginDetails
       case userRecord of
-        Nothing -> sendResponseStatus error404 $ toJSON ("email does not exist, please register or try again" :: T.Text)
+        Nothing -> sendResponseStatus error404 $ toJSON
+          ("email does not exist, please register or try again" :: T.Text)
         Just entity@(Entity _ dbUser) -> if (invalidPassword)
-          then sendResponseStatus error404 $ toJSON ("invalid password, please try again" :: T.Text)
-          else return $ toJSON $ UserResponse jwt $ userName dbUser
-            where
-              invalidPassword = not $ verifyPassword (encodeUtf8 . loginPassword $ loginDetails) (encodeUtf8 . userPassword $ dbUser)
-              -- cs = JWT.def { JWT.unregisteredClaims =
-              --   Map.fromList [("id", String . tshow . fromSqlKey $ )]
-              -- }
-              jwt = JWT.encodeSigned JWT.HS256 mySecret $ makeJWTClaimsSet $ entityKey entity
+          then sendResponseStatus error404
+            $ toJSON ("invalid password, please try again" :: T.Text)
+          else
+            return
+            $ toJSON
+            $ UserResponse (jwt $ JWT.secret $ jwtSecret $ appSettings app)
+            $ userName dbUser
+         where
+          invalidPassword = not $ verifyPassword
+            (encodeUtf8 . loginPassword $ loginDetails)
+            (encodeUtf8 . userPassword $ dbUser)
+          -- cs = JWT.def { JWT.unregisteredClaims =
+          --   Map.fromList [("id", String . tshow . fromSqlKey $ )]
+          -- }
+          jwt secret =
+            JWT.encodeSigned JWT.HS256 secret $ makeJWTClaimsSet $ entityKey
+              entity
 
 
 -- TODO: Make sure username and email are lowercased
 postRegisterR :: HandlerFor App Value
 postRegisterR = do
+  app  <- getYesod
   body <- requireCheckJsonBody :: Handler Value
-  let unvalidatedUser  =  fromJSON body :: Result UnvalidatedUser
-  let validatedUser    =  passwordValidator
-                      =<< emailValidator
-                      =<< nameValidator
-                      =<< unvalidatedUser
+  let unvalidatedUser = fromJSON body :: Result UnvalidatedUser
+  let validatedUser =
+        passwordValidator
+          =<< emailValidator
+          =<< nameValidator
+          =<< unvalidatedUser
   case validatedUser of
     (Error   str) -> sendResponseStatus error500 $ toJSON str
     (Success vu ) -> do
       hashedPassword <- liftIO
         $ (flip makePassword 10 . encodeUtf8 . password) vu
-      dbEntity <- runDB $ insert $ makeValidatedUser hashedPassword vu
-      return $ toJSON 
-             $ UserResponse 
-                (JWT.encodeSigned JWT.HS256 mySecret (makeJWTClaimsSet dbEntity))
-             $ Model.User.name vu
+      dbEntity <- catch
+        (runDB $ insert $ makeValidatedUser hashedPassword vu)
+        (\e -> do
+          case e of
+            -- TODO: match error to determine if it's unique email or unique username error
+            (SqlError _ _ msg _ _) ->
+              sendResponseStatus error500
+                $ toJSON
+                $ ("email already registered" :: Text)
+            _ -> sendResponseStatus error500 $ toJSON $ show e
+        )
+      return
+        $ toJSON
+        $ UserResponse
+            (JWT.encodeSigned JWT.HS256
+                              (JWT.secret $ jwtSecret $ appSettings app)
+                              (makeJWTClaimsSet dbEntity)
+            )
+        $ Model.User.name vu
 
 makeValidatedUser :: ByteString -> UnvalidatedUser -> User
 makeValidatedUser hashedPassword (UnvalidatedUser uvName uvEmail _) =

hastock/src/Model/User.hs

@@ -54,6 +54,8 @@ PTH.share [PTH.mkPersist PTH.sqlSettings, PTH.mkMigrate "migrateAll"] [PTH.persi
 instance ToJSON User where
   toJSON (User userName userEmail _) = object ["username" .= userName, "email" .= userEmail]
 
+getUserName :: User -> Text
+getUserName (User n _ _) = n
 
 data UserResponse = UserResponse { userResponseToken :: Text
                                  , userResponseName :: Text

hastock/src/Settings.hs

@@ -61,6 +61,7 @@ data AppSettings = AppSettings
     , databaseUser              :: ByteString
     , databaseName              :: ByteString
     , databasePw                :: ByteString
+    , jwtSecret                 :: Text
     }
 
 instance FromJSON AppSettings where
@@ -93,7 +94,7 @@ instance FromJSON AppSettings where
         databaseUser              <-  fromString <$> o .: "dbUser"
         databaseName              <-  fromString <$> o .: "dbName"
         databasePw                <-  fromString <$> o .: "dbPassword"
-
+        jwtSecret                 <-  fromString <$> o .: "jwtSecret"
         return AppSettings {..}
 
 -- | Settings for 'widgetFile', such as which template languages to support and

hastock/stack.yaml.lock

@@ -0,0 +1,19 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages:
+- completed:
+    hackage: jwt-0.7.2@sha256:b5858c05476741b4dc7f9f075bb8c8aca128ed25a9f325d937d370aa3d4910e1,4073
+    pantry-tree:
+      size: 978
+      sha256: 8e5b90fe8051580276d073ec028eeb2073f993c42ed9db040d73261978687a0b
+  original:
+    hackage: jwt-0.7.2@sha256:b5858c05476741b4dc7f9f075bb8c8aca128ed25a9f325d937d370aa3d4910e1
+snapshots:
+- completed:
+    size: 498402
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/24.yaml
+    sha256: 33e96adfe24f112b62f6edd22565cdbaa13155703bbfbfdc3d0a9bc6138ae7bf
+  original: lts-13.24