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

Purr.cabal

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

src/Core/Configuration.hs

@@ -1,8 +1,8 @@
 module Core.Configuration ( main ) where
 
-import Core.Types
+import           Core.Types
 
-import Dhall
+import           Dhall
 
 instance FromDhall DhallConfig
 

src/Core/HTTP.hs

@@ -1,16 +1,16 @@
 module Core.HTTP ( app ) where
 
-import Core.Types
+import           Core.Types
 
-import Core.Templates          (renderIndex, renderStyle)
-import Feature.Sharing.HTTP    as Sharing
-import Feature.Generation.HTTP as Generation
+import           Core.Templates                       (renderIndex, renderStyle)
+import           Feature.Generation.HTTP              as Generation
+import           Feature.Sharing.HTTP                 as Sharing
 
-import Control.Monad.Reader (ask, lift)
-import Data.Maybe                           (Maybe (Nothing))
-import Network.Wai.Middleware.RequestLogger (logStdoutDev)
-import Network.Wai.Middleware.Static
-import Web.Scotty.Trans
+import           Control.Monad.Reader                 (ask, lift)
+import           Data.Maybe                           (Maybe (Nothing))
+import           Network.Wai.Middleware.RequestLogger (logStdoutDev)
+import           Network.Wai.Middleware.Static
+import           Web.Scotty.Trans
 
 app :: PurrApp ()
 app = do

src/Core/SQLite.hs

@@ -1,17 +1,17 @@
 module Core.SQLite where
 
-import Core.Types
+import           Core.Types
 
-import Control.Monad.Reader           (ask, lift, liftIO)
-import Database.SQLite.Simple
-import Database.SQLite.Simple.FromRow
+import           Control.Monad.Reader           (ask, lift, liftIO)
+import           Database.SQLite.Simple
+import           Database.SQLite.Simple.FromRow
 
-import qualified Data.Text                  as T
+import qualified Data.Text                      as T
 
 main :: String -> IO ()
-main db = do 
+main db = do
   conn <- open db
-  execute_ conn 
+  execute_ conn
     "CREATE TABLE IF NOT EXISTS pws\
     \ (link TEXT PRIMARY KEY,\
     \ secret TEXT,\

src/Core/Templates.hs

@@ -1,17 +1,17 @@
-{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE QuasiQuotes     #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module Core.Templates ( renderIndex, renderStyle, hxVals ) where
 
-import Text.Blaze.Html.Renderer.Text (renderHtml)
-import Text.Blaze.Html
-import Text.Cassius                  (cassiusFile, renderCss)
-import Text.Hamlet                   (shamletFile)
+import           Text.Blaze.Html
+import           Text.Blaze.Html.Renderer.Text (renderHtml)
+import           Text.Cassius                  (cassiusFile, renderCss)
+import           Text.Hamlet                   (shamletFile)
 
-import qualified Data.Text      as T
-import qualified Data.Text.Lazy as LT
+import qualified Data.Text                     as T
+import qualified Data.Text.Lazy                as LT
 
-import Prelude 
+import           Prelude
 
 renderIndex :: String -> String -> LT.Text
 renderIndex link email = renderHtml ( $(shamletFile "./views/index.hamlet") )

src/Core/Types.hs

@@ -1,20 +1,34 @@
 module Core.Types where
 
-import qualified Data.Text.Lazy as LT
+import qualified Data.Text                      as T
+import qualified Data.Text.Lazy                 as LT
 
-import Control.Monad.Reader (MonadIO, MonadReader, ReaderT)
-import Data.Text
-import GHC.Generics         (Generic)
-import Numeric.Natural      (Natural)
-import Web.Scotty.Trans     (ScottyT, ActionT)
+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           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

src/Feature/Generation/HTTP.hs

@@ -1,28 +1,25 @@
 module Feature.Generation.HTTP ( routes ) where
 
-import Core.Types
-import Core.Templates (renderIndex)
+import           Core.Templates               (renderIndex)
+import           Core.Types
 
-import Feature.Generation.Passwords 
-  ( suggestedScheme
-  , xkcd
-  , oldschool
-  , gibberish )
-import Feature.Generation.Templates (renderGen)
+import           Feature.Generation.Passwords (gibberish, oldschool,
+                                               suggestedScheme, xkcd)
+import           Feature.Generation.Templates (renderGen)
 
-import qualified Data.Text      as T
-import qualified Data.Text.Lazy as LT
+import qualified Data.Text                    as T
+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           Control.Monad.Reader         (ask, lift, liftIO)
+import           Data.Maybe                   (listToMaybe)
+import           Prelude
+import           Web.Scotty.Trans
 
 routes :: PurrApp ()
-routes = do 
+routes = do
 
   get "/gen" $ do
     genXkcd      <- liftIO $ xkcd
     genOldschool <- liftIO $ oldschool
     genGibberish <- liftIO $ gibberish 12
-    html   $ renderGen genXkcd genOldschool genGibberish
+    html $ renderGen genXkcd genOldschool genGibberish

src/Feature/Generation/Links.hs

@@ -1,16 +1,10 @@
 module Feature.Generation.Links ( genLink ) where
 
-import Core.Types
-import Feature.Generation.Shared (rIndex, rChar, validChars)
+import           Core.Types
+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
+import           Control.Monad.Reader      (ask, lift)
+import           Data.List                 (singleton)
 
 -- Generates a string containing romly generated and capitalized
 -- characters. The number of characters used is defined in the global config.dhall.

src/Feature/Generation/Passwords.hs

@@ -1,36 +1,26 @@
-module Feature.Generation.Passwords 
+module Feature.Generation.Passwords
   ( Password
+  , Random
   , suggestedScheme
   , xkcd
   , oldschool
-  , gibberish 
+  , gibberish
   ) where
 
-import Core.Types
-import Feature.Generation.Shared 
-  ( camelCase
-  , rCharSym
-  , rIndex
-  , validChars
-  , validNumbers
-  , validSymbols 
-  )
+import           Core.Types
+import           Feature.Generation.Shared (camelCase, rCharSym, rIndex,
+                                            validChars, validNumbers,
+                                            validSymbols)
 
-import Data.List (singleton)
+import           Data.List                 (singleton)
 
-newtype Password = Password' String
-  deriving (Eq, Ord)
-
-instance Show Password where 
-  show (Password' a) = a
-
-suggestedScheme :: Int -> IO Password
-suggestedScheme i 
+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,38 +28,38 @@ xkcd = do
   wFour  <- rCamel
   return  $ Password' (wOne <> wTwo <> wThree <> wFour)
 
-oldschool :: IO Password
+oldschool :: Random Password
 oldschool = do
   wOne <- rCamel
   wTwo <- rCamel
   nOne <- rNum
-  nTwo <- rNum 
+  nTwo <- rNum
   nThr <- rNum
   nFou <- rNum
   sOne <- rSym
-  return 
-    $ Password' (wOne <> wTwo 
+  return
+    $ Password' (wOne <> wTwo
    <> 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")

src/Feature/Generation/Shared.hs

@@ -1,14 +1,14 @@
 module Feature.Generation.Shared where
 
-import Data.Char (intToDigit, toLower, toUpper)
-import System.Random (randomRIO)
+import           Data.Char     (intToDigit, toLower, toUpper)
+import           System.Random (randomRIO)
 
 rIndex :: [a] -> IO a
-rIndex arr = randomRIO (0, length arr - 1) 
+rIndex arr = randomRIO (0, length arr - 1)
   >>= (\i -> return $ arr !! i)
 
 rCap :: Char -> IO Char
-rCap c = rIndex [True,False] >>= (\r -> return $ rCap' r c)  
+rCap c = rIndex [True,False] >>= (\r -> return $ rCap' r c)
   where
     rCap' :: Bool -> Char -> Char
     rCap' True  c = toUpper c
@@ -22,7 +22,7 @@ rCharSym = rIndex (validChars <> validSymbols)>>= rCap
 
 camelCase :: [Char] -> [Char]
 camelCase [] = []
-camelCase x = toUpper (head x) : map toLower (tail x)
+camelCase x  = toUpper (head x) : map toLower (tail x)
 
 validChars :: [Char]
 validChars = validLetters <> fmap intToDigit validNumbers

src/Feature/Generation/Templates.hs

@@ -1,19 +1,19 @@
-{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE QuasiQuotes     #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module Feature.Generation.Templates ( renderGen ) where
 
-import Core.Templates (hxVals)
-import Feature.Generation.Passwords (Password)
+import           Core.Templates                (hxVals)
+import           Feature.Generation.Passwords  (Password)
 
-import qualified Data.Text      as T
-import qualified Data.Text.Lazy as LT
+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.Hamlet                     (shamletFile)
+import           Text.Blaze.Html
+import           Text.Blaze.Html.Renderer.Text (renderHtml)
+import           Text.Hamlet                   (shamletFile)
 
-import Prelude 
+import           Prelude
 
 renderGen :: Password -> Password -> Password -> LT.Text
 renderGen genXkcd genOldschool genGibberish = renderHtml ( $(shamletFile "./views/gen.hamlet") )

src/Feature/Sharing/HTTP.hs

@@ -1,26 +1,25 @@
 module Feature.Sharing.HTTP ( routes ) where
 
-import Core.SQLite (confLinkLength)
-import Core.Types
-import Core.Templates (renderIndex)
+import           Core.SQLite               (confLinkLength)
+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           Feature.Generation.Links  (genLink)
+import           Feature.Sharing.SQLite    (findByLink, insertNewSecret)
+import           Feature.Sharing.Templates (renderPw)
 
-import Control.Monad.Reader (ask, lift, liftIO)
-import Data.Maybe           (listToMaybe)
-import Data.List.Split      (splitOn)
-import Web.Scotty.Trans 
-import Prelude 
+import           Control.Monad.Reader      (ask, lift, liftIO)
+import           Data.List.Split           (splitOn)
+import           Data.Maybe                (listToMaybe)
+import           Prelude
+import           Web.Scotty.Trans
 
-import qualified Data.Text      as T
-import qualified Data.Text.Lazy as LT
+import qualified Data.Text                 as T
+import qualified Data.Text.Lazy            as LT
 
 
 routes :: PurrApp ()
-routes = do 
+routes = do
 
   get "/pw/:id" $ do
     reqId <- param "id"
@@ -32,7 +31,7 @@ routes = do
     res   <- findByLink reqId
     html   $ renderPw (last $ splitOn "/" reqId) res
 
-  post "/new" $ do 
+  post "/new" $ do
     reqSecret <- param "newSec"
     reqDur    <- param "newSecDuration"
     reqViews  <- param "newSecViews"

src/Feature/Sharing/SQLite.hs

@@ -1,22 +1,21 @@
 module Feature.Sharing.SQLite where
 
-import Core.Types
-import Core.SQLite
-import Feature.Generation.Passwords (Password)
-import Feature.Sharing.Types
+import           Core.SQLite
+import           Core.Types
+import           Feature.Generation.Passwords (Password)
 
-import Control.Monad.Reader           (ask, lift, liftIO)
-import Crypto.Simple.CBC              (encrypt, decrypt)
-import Data.Maybe                     (listToMaybe)
-import Data.Time.Clock.POSIX          (getPOSIXTime)
-import Data.List.Split                (splitOn)
-import Database.SQLite.Simple
+import           Control.Monad.Reader         (ask, lift, liftIO)
+import           Crypto.Simple.CBC            (decrypt, encrypt)
+import           Data.List.Split              (splitOn)
+import           Data.Maybe                   (listToMaybe)
+import           Data.Time.Clock.POSIX        (getPOSIXTime)
+import           Database.SQLite.Simple
 
-import qualified Data.ByteString.Base64 as B64
-import qualified Data.ByteString.Char8  as B
-import qualified Data.Text              as T
-import qualified Data.Text.Encoding     as ET
-import qualified Data.Text.Lazy         as LT
+import qualified Data.ByteString.Base64       as B64
+import qualified Data.ByteString.Char8        as B
+import qualified Data.Text                    as T
+import qualified Data.Text.Encoding           as ET
+import qualified Data.Text.Lazy               as LT
 
 findByLink :: String -> PurrAction (Maybe T.Text)
 findByLink link = do
@@ -34,7 +33,7 @@ insertNewSecret sec life link maxViews = do
   encSec <- liftIO $ encryptSecret key sec
   conn   <- liftIO $ open db
   time   <- liftIO $ epochTime
-  liftIO  $ execute conn 
+  liftIO  $ execute conn
     "INSERT INTO pws (link, secret, date, life, views, maxViews) VALUES (?, ?, ?, ?, ?, ?)"
       (SecretEntry link (encodeSecret encSec) time life 0 maxViews)
   liftIO  $ close conn
@@ -44,9 +43,9 @@ readEncryptedSecret key sec = do
   db     <- dbPath
   liftIO  $ incViews sec db
   delete <- liftIO $ deleteExpiredSecret sec db
-  decKey <- liftIO ( sequence 
-                   $ decryptSecret key 
-                 <$> decodeSecret 
+  decKey <- liftIO ( sequence
+                   $ decryptSecret key
+                 <$> decodeSecret
                  <$> listToMaybe sec )
   if (delete)
     then return Nothing
@@ -66,18 +65,18 @@ deleteExpiredSecret :: [SecretEntry] -> String -> IO Bool
 deleteExpiredSecret []         _ = return False
 deleteExpiredSecret (sec : _) db = do
   time <- liftIO $ epochTime
-  if ((date sec) + ((life sec) * 86400) < time) || (views sec >= maxViews sec) 
+  if ((date sec) + ((life sec) * 86400) < time) || (views sec >= maxViews sec)
     then deleteSec sec db
     else return False
     where
       deleteSec :: SecretEntry -> String -> IO Bool
       deleteSec sec db = do
         conn  <- liftIO $ open db
-        liftIO $ execute conn 
+        liftIO $ execute conn
           "DELETE FROM pws WHERE link = ?" (Only (link sec))
         liftIO $ close conn
         return True
-  
+
 encodeSecret :: B.ByteString -> T.Text
 encodeSecret b = ET.decodeUtf8 $ B64.encode b
 
@@ -88,7 +87,7 @@ encryptSecret :: String -> T.Text -> IO B.ByteString
 encryptSecret k s = encrypt (B.pack k) (ET.encodeUtf8 s)
 
 decryptSecret :: String -> B.ByteString -> IO B.ByteString
-decryptSecret k b = decrypt (B.pack k) b 
+decryptSecret k b = decrypt (B.pack k) b
 
 epochTime :: IO Integer
 epochTime = fmap round getPOSIXTime

src/Feature/Sharing/Templates.hs

@@ -1,16 +1,18 @@
-{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE QuasiQuotes     #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module Feature.Sharing.Templates ( renderPw ) where
 
-import qualified Data.Text      as T
-import qualified Data.Text.Lazy as LT
+import           Core.Types
 
-import Text.Blaze.Html.Renderer.Text   (renderHtml)
-import Text.Blaze.Html
-import Text.Hamlet                     (shamletFile)
+import qualified Data.Text                     as T
+import qualified Data.Text.Lazy                as LT
 
-import Prelude 
+import           Text.Blaze.Html
+import           Text.Blaze.Html.Renderer.Text (renderHtml)
+import           Text.Hamlet                   (shamletFile)
+
+import           Prelude
 
 renderPw :: String -> Maybe T.Text -> LT.Text
 renderPw link password = renderHtml ( $(shamletFile "./views/pw.hamlet") )

src/Feature/Sharing/Types.hs

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

src/Lib.hs

@@ -1,14 +1,14 @@
 module Lib ( main ) where
 
-import qualified Core.Configuration as Configuration
-import qualified Core.HTTP          as HTTP
-import qualified Core.SQLite        as DB
+import qualified Core.Configuration   as Configuration
+import qualified Core.HTTP            as HTTP
+import qualified Core.SQLite          as DB
 import           Core.Types
 
-import Control.Monad.Reader (lift, liftIO, runReaderT)
-import GHC.Natural          (popCountNatural)
-import Prelude              hiding (id)
-import Web.Scotty.Trans     (scottyT)
+import           Control.Monad.Reader (lift, liftIO, runReaderT)
+import           GHC.Natural          (popCountNatural)
+import           Prelude              hiding (id)
+import           Web.Scotty.Trans     (scottyT)
 
 main :: IO ()
 main = do