James/purr
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Start formatting with stylish-haskell. Start refactoring for clearer types.

Browse Source
This commit is contained in:
James Eversole 2023-01-10 21:53:10 -06:00
parent 84c49319a6
commit cb45c4ce1d
16 changed files with 185 additions and 180 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Purr.cabal
View File

@ -32,7 +32,6 @@ library
Feature.Sharing.HTTP
Feature.Sharing.SQLite
Feature.Sharing.Templates
Feature.Sharing.Types
Lib
other-modules:
Paths_Purr

2
src/Core/HTTP.hs
View File

@ -3,8 +3,8 @@ module Core.HTTP ( app ) where
import Core.Types
import Core.Templates (renderIndex, renderStyle)
import Feature.Sharing.HTTP as Sharing
import Feature.Generation.HTTP as Generation
import Feature.Sharing.HTTP as Sharing
import Control.Monad.Reader (ask, lift)
import Data.Maybe (Maybe (Nothing))

2
src/Core/Templates.hs
View File

@ -3,8 +3,8 @@
module Core.Templates ( renderIndex, renderStyle, hxVals ) where
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Text.Blaze.Html
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Text.Cassius (cassiusFile, renderCss)
import Text.Hamlet (shamletFile)

49
src/Core/Types.hs
View File

@ -1,20 +1,34 @@
module Core.Types where
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import Control.Monad.Reader (MonadIO, MonadReader, ReaderT)
import Data.Text
import Database.SQLite.Simple (ToRow)
import Database.SQLite.Simple.FromRow (FromRow)
import GHC.Generics (Generic)
import Numeric.Natural (Natural)
import Web.Scotty.Trans (ScottyT, ActionT)
import Text.Blaze.Html
import Web.Scotty.Trans (ActionT, ScottyT)
type PurrApp a = ScottyT LT.Text ConfigM a
type PurrAction a = ActionT LT.Text ConfigM a
type Random a = IO a
newtype ConfigM a = ConfigM
{ runConfigM :: ReaderT DhallConfig IO a
} deriving (Applicative, Functor, Monad, MonadIO, MonadReader DhallConfig)
newtype Password = Password' String
deriving (Eq, Ord)
newtype UserSecret = UserSecret' String
deriving (Eq, Ord)
newtype GenLink = GenLink' String
deriving (Eq, Ord)
data DhallConfig = DhallConfig
{ environment :: String
, applicationHost :: String
@ -24,3 +38,36 @@ data DhallConfig = DhallConfig
, linkLength :: Int
, adminEmail :: String
} deriving (Generic, Show)
data SecretEntry = SecretEntry
{ link :: T.Text
, secret :: T.Text
, date :: Integer
, life :: Integer
, views :: Integer
, maxViews :: Integer
} deriving (Show, Generic)
data Secret = Password | UserSecret
deriving (Show, Generic)
instance Show GenLink where
show (GenLink' a) = a
instance Show Password where
show (Password' a) = a
instance Show UserSecret where
show (UserSecret' a) = a
instance ToMarkup Password where
toMarkup = toMarkup . show
instance ToMarkup UserSecret where
toMarkup = toMarkup . show
instance ToMarkup Secret where
toMarkup = toMarkup . show
instance FromRow SecretEntry where
instance ToRow SecretEntry where

11
src/Feature/Generation/HTTP.hs
View File

@ -1,13 +1,10 @@
module Feature.Generation.HTTP ( routes ) where
import Core.Types
import Core.Templates (renderIndex)
import Core.Types
import Feature.Generation.Passwords
( suggestedScheme
, xkcd
, oldschool
, gibberish )
import Feature.Generation.Passwords (gibberish, oldschool,
suggestedScheme, xkcd)
import Feature.Generation.Templates (renderGen)
import qualified Data.Text as T
@ -15,8 +12,8 @@ import qualified Data.Text.Lazy as LT
import Control.Monad.Reader (ask, lift, liftIO)
import Data.Maybe (listToMaybe)
import Web.Scotty.Trans
import Prelude
import Web.Scotty.Trans
routes :: PurrApp ()
routes = do

8
src/Feature/Generation/Links.hs
View File

@ -1,17 +1,11 @@
module Feature.Generation.Links ( genLink ) where
import Core.Types
import Feature.Generation.Shared (rIndex, rChar, validChars)
import Feature.Generation.Shared (rChar, rIndex, validChars)
import Control.Monad.Reader (ask, lift)
import Data.List (singleton)
newtype GenLink = GenLink' String
deriving (Eq, Ord)
instance Show GenLink where
show (GenLink' a) = a
-- Generates a string containing romly generated and capitalized
-- characters. The number of characters used is defined in the global config.dhall.
genLink :: Int -> IO GenLink

38
src/Feature/Generation/Passwords.hs
View File

@ -1,5 +1,6 @@
module Feature.Generation.Passwords
( Password
, Random
, suggestedScheme
, xkcd
, oldschool
@ -7,30 +8,19 @@ module Feature.Generation.Passwords
) where
import Core.Types
import Feature.Generation.Shared
( camelCase
, rCharSym
, rIndex
, validChars
, validNumbers
, validSymbols
)
import Feature.Generation.Shared (camelCase, rCharSym, rIndex,
validChars, validNumbers,
validSymbols)
import Data.List (singleton)
newtype Password = Password' String
deriving (Eq, Ord)
instance Show Password where
show (Password' a) = a
suggestedScheme :: Int -> IO Password
suggestedScheme :: Int -> Random Password
suggestedScheme i
| i > 17 = xkcd
| i > 12 = oldschool
| otherwise = gibberish i
xkcd :: IO Password
xkcd :: Random Password
xkcd = do
wOne <- rCamel
wTwo <- rCamel
@ -38,7 +28,7 @@ xkcd = do
wFour <- rCamel
return $ Password' (wOne <> wTwo <> wThree <> wFour)
oldschool :: IO Password
oldschool :: Random Password
oldschool = do
wOne <- rCamel
wTwo <- rCamel
@ -52,24 +42,24 @@ oldschool = do
<> show nOne <> show nTwo <> show nThr <> show nFou
<> pure sOne)
gibberish :: Int -> IO Password
gibberish :: Int -> Random Password
gibberish i = go i (return "")
where
go :: Int -> IO String -> IO Password
go :: Int -> Random String -> Random Password
go 0 s = Password' <$> s
go i s = go (i - 1) (s <> (singleton <$> rCharSym))
rNum :: IO Int
rNum :: Random Int
rNum = rIndex validNumbers
rWord :: IO String
rWord :: Random String
rWord = wordList >>= rIndex
rSym :: IO Char
rSym :: Random Char
rSym = rIndex validSymbols
rCamel :: IO String
rCamel :: Random String
rCamel = camelCase <$> rWord
wordList :: IO [String]
wordList :: Random [String]
wordList = fmap lines (readFile "./src/Feature/Generation/wordlist.txt")

2
src/Feature/Generation/Templates.hs
View File

@ -9,8 +9,8 @@ import Feature.Generation.Passwords (Password)
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Text.Blaze.Html
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Text.Hamlet (shamletFile)
import Prelude

7
src/Feature/Sharing/HTTP.hs
View File

@ -1,19 +1,18 @@
module Feature.Sharing.HTTP ( routes ) where
import Core.SQLite (confLinkLength)
import Core.Types
import Core.Templates (renderIndex)
import Core.Types
import Feature.Generation.Links (genLink)
import Feature.Sharing.SQLite (findByLink, insertNewSecret)
import Feature.Sharing.Templates (renderPw)
import Feature.Sharing.Types
import Control.Monad.Reader (ask, lift, liftIO)
import Data.Maybe (listToMaybe)
import Data.List.Split (splitOn)
import Web.Scotty.Trans
import Data.Maybe (listToMaybe)
import Prelude
import Web.Scotty.Trans
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT

7
src/Feature/Sharing/SQLite.hs
View File

@ -1,15 +1,14 @@
module Feature.Sharing.SQLite where
import Core.Types
import Core.SQLite
import Core.Types
import Feature.Generation.Passwords (Password)
import Feature.Sharing.Types
import Control.Monad.Reader (ask, lift, liftIO)
import Crypto.Simple.CBC (encrypt, decrypt)
import Crypto.Simple.CBC (decrypt, encrypt)
import Data.List.Split (splitOn)
import Data.Maybe (listToMaybe)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.List.Split (splitOn)
import Database.SQLite.Simple
import qualified Data.ByteString.Base64 as B64

4
src/Feature/Sharing/Templates.hs
View File

@ -3,11 +3,13 @@
module Feature.Sharing.Templates ( renderPw ) where
import Core.Types
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Text.Blaze.Html
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Text.Hamlet (shamletFile)
import Prelude

22
src/Feature/Sharing/Types.hs
View File

@ -1,22 +0,0 @@
module Feature.Sharing.Types where
import Data.Map.Strict (Map)
import Data.Typeable (Typeable)
import GHC.Generics
import Database.SQLite.Simple
import Database.SQLite.Simple.FromRow
import qualified Data.Text as T
data SecretEntry = SecretEntry
{ link :: T.Text
, secret :: T.Text
, date :: Integer
, life :: Integer
, views :: Integer
, maxViews :: Integer
} deriving (Show, Generic)
instance FromRow SecretEntry where
instance ToRow SecretEntry where