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           Core.Templates                       (renderIndex, renderStyle)
-import Feature.Sharing.HTTP    as Sharing
+import           Feature.Generation.HTTP              as Generation
-import Feature.Generation.HTTP as Generation
+import           Feature.Sharing.HTTP                 as Sharing
 
-import Control.Monad.Reader (ask, lift)
+import           Control.Monad.Reader                 (ask, lift)
-import Data.Maybe                           (Maybe (Nothing))
+import           Data.Maybe                           (Maybe (Nothing))
-import Network.Wai.Middleware.RequestLogger (logStdoutDev)
+import           Network.Wai.Middleware.RequestLogger (logStdoutDev)
-import Network.Wai.Middleware.Static
+import           Network.Wai.Middleware.Static
-import Web.Scotty.Trans
+import           Web.Scotty.Trans
 
 app :: PurrApp ()
 app = do

src/Core/SQLite.hs

@@ -1,12 +1,12 @@
 module Core.SQLite where
 
-import Core.Types
+import           Core.Types
 
-import Control.Monad.Reader           (ask, lift, liftIO)
+import           Control.Monad.Reader           (ask, lift, liftIO)
-import Database.SQLite.Simple
+import           Database.SQLite.Simple
-import Database.SQLite.Simple.FromRow
+import           Database.SQLite.Simple.FromRow
 
-import qualified Data.Text                  as T
+import qualified Data.Text                      as T
 
 main :: String -> IO ()
 main db = do

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.Blaze.Html
+import           Text.Blaze.Html.Renderer.Text (renderHtml)
-import Text.Cassius                  (cassiusFile, renderCss)
+import           Text.Cassius                  (cassiusFile, renderCss)
-import Text.Hamlet                   (shamletFile)
+import           Text.Hamlet                   (shamletFile)
 
-import qualified Data.Text      as T
+import qualified Data.Text                     as T
-import qualified Data.Text.Lazy as LT
+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           Control.Monad.Reader           (MonadIO, MonadReader, ReaderT)
-import Data.Text
+import           Data.Text
-import GHC.Generics         (Generic)
+import           Database.SQLite.Simple         (ToRow)
-import Numeric.Natural      (Natural)
+import           Database.SQLite.Simple.FromRow (FromRow)
-import Web.Scotty.Trans     (ScottyT, ActionT)
+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,22 +1,19 @@
 module Feature.Generation.HTTP ( routes ) where
 
-import Core.Types
+import           Core.Templates               (renderIndex)
-import Core.Templates (renderIndex)
+import           Core.Types
 
-import Feature.Generation.Passwords 
+import           Feature.Generation.Passwords (gibberish, oldschool,
-  ( suggestedScheme
+                                               suggestedScheme, xkcd)
-  , xkcd
+import           Feature.Generation.Templates (renderGen)
-  , oldschool
-  , gibberish )
-import Feature.Generation.Templates (renderGen)
 
-import qualified Data.Text      as T
+import qualified Data.Text                    as T
-import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy               as LT
 
-import Control.Monad.Reader (ask, lift, liftIO)
+import           Control.Monad.Reader         (ask, lift, liftIO)
-import Data.Maybe (listToMaybe)
+import           Data.Maybe                   (listToMaybe)
-import Web.Scotty.Trans 
+import           Prelude
-import Prelude 
+import           Web.Scotty.Trans
 
 routes :: PurrApp ()
 routes = do
@@ -25,4 +22,4 @@ routes = 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           Core.Types
-import Feature.Generation.Shared (rIndex, rChar, validChars)
+import           Feature.Generation.Shared (rChar, rIndex, validChars)
 
-import Control.Monad.Reader (ask, lift)
+import           Control.Monad.Reader      (ask, lift)
-import Data.List (singleton)
+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.

src/Feature/Generation/Passwords.hs

@@ -1,36 +1,26 @@
 module Feature.Generation.Passwords
   ( Password
+  , Random
   , suggestedScheme
   , xkcd
   , oldschool
   , gibberish
   ) where
 
-import Core.Types
+import           Core.Types
-import Feature.Generation.Shared 
+import           Feature.Generation.Shared (camelCase, rCharSym, rIndex,
-  ( camelCase
+                                            validChars, validNumbers,
-  , rCharSym
+                                            validSymbols)
-  , rIndex
-  , validChars
-  , validNumbers
-  , validSymbols 
-  )
 
-import Data.List (singleton)
+import           Data.List                 (singleton)
 
-newtype Password = Password' String
+suggestedScheme :: Int -> Random Password
-  deriving (Eq, Ord)
-
-instance Show Password where 
-  show (Password' a) = a
-
-suggestedScheme :: Int -> IO 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")

src/Feature/Generation/Shared.hs

@@ -1,7 +1,7 @@
 module Feature.Generation.Shared where
 
-import Data.Char (intToDigit, toLower, toUpper)
+import           Data.Char     (intToDigit, toLower, toUpper)
-import System.Random (randomRIO)
+import           System.Random (randomRIO)
 
 rIndex :: [a] -> IO a
 rIndex arr = randomRIO (0, length arr - 1)
@@ -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           Core.Templates                (hxVals)
-import Feature.Generation.Passwords (Password)
+import           Feature.Generation.Passwords  (Password)
 
-import qualified Data.Text      as T
+import qualified Data.Text                     as T
-import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy                as LT
 
-import Text.Blaze.Html.Renderer.Text   (renderHtml)
+import           Text.Blaze.Html
-import Text.Blaze.Html
+import           Text.Blaze.Html.Renderer.Text (renderHtml)
-import Text.Hamlet                     (shamletFile)
+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,22 +1,21 @@
 module Feature.Sharing.HTTP ( routes ) where
 
-import Core.SQLite (confLinkLength)
+import           Core.SQLite               (confLinkLength)
-import Core.Types
+import           Core.Templates            (renderIndex)
-import Core.Templates (renderIndex)
+import           Core.Types
 
-import Feature.Generation.Links  (genLink)
+import           Feature.Generation.Links  (genLink)
-import Feature.Sharing.SQLite    (findByLink, insertNewSecret)
+import           Feature.Sharing.SQLite    (findByLink, insertNewSecret)
-import Feature.Sharing.Templates (renderPw)
+import           Feature.Sharing.Templates (renderPw)
-import Feature.Sharing.Types
 
-import Control.Monad.Reader (ask, lift, liftIO)
+import           Control.Monad.Reader      (ask, lift, liftIO)
-import Data.Maybe           (listToMaybe)
+import           Data.List.Split           (splitOn)
-import Data.List.Split      (splitOn)
+import           Data.Maybe                (listToMaybe)
-import Web.Scotty.Trans 
+import           Prelude
-import Prelude 
+import           Web.Scotty.Trans
 
-import qualified Data.Text      as T
+import qualified Data.Text                 as T
-import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy            as LT
 
 
 routes :: PurrApp ()

src/Feature/Sharing/SQLite.hs

@@ -1,22 +1,21 @@
 module Feature.Sharing.SQLite where
 
-import Core.Types
+import           Core.SQLite
-import Core.SQLite
+import           Core.Types
-import Feature.Generation.Passwords (Password)
+import           Feature.Generation.Passwords (Password)
-import Feature.Sharing.Types
 
-import Control.Monad.Reader           (ask, lift, liftIO)
+import           Control.Monad.Reader         (ask, lift, liftIO)
-import Crypto.Simple.CBC              (encrypt, decrypt)
+import           Crypto.Simple.CBC            (decrypt, encrypt)
-import Data.Maybe                     (listToMaybe)
+import           Data.List.Split              (splitOn)
-import Data.Time.Clock.POSIX          (getPOSIXTime)
+import           Data.Maybe                   (listToMaybe)
-import Data.List.Split                (splitOn)
+import           Data.Time.Clock.POSIX        (getPOSIXTime)
-import Database.SQLite.Simple
+import           Database.SQLite.Simple
 
-import qualified Data.ByteString.Base64 as B64
+import qualified Data.ByteString.Base64       as B64
-import qualified Data.ByteString.Char8  as B
+import qualified Data.ByteString.Char8        as B
-import qualified Data.Text              as T
+import qualified Data.Text                    as T
-import qualified Data.Text.Encoding     as ET
+import qualified Data.Text.Encoding           as ET
-import qualified Data.Text.Lazy         as LT
+import qualified Data.Text.Lazy               as LT
 
 findByLink :: String -> PurrAction (Maybe T.Text)
 findByLink link = do

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           Core.Types
-import qualified Data.Text.Lazy as LT
 
-import Text.Blaze.Html.Renderer.Text   (renderHtml)
+import qualified Data.Text                     as T
-import Text.Blaze.Html
+import qualified Data.Text.Lazy                as LT
-import Text.Hamlet                     (shamletFile)
 
-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.Configuration   as Configuration
-import qualified Core.HTTP          as HTTP
+import qualified Core.HTTP            as HTTP
-import qualified Core.SQLite        as DB
+import qualified Core.SQLite          as DB
 import           Core.Types
 
-import Control.Monad.Reader (lift, liftIO, runReaderT)
+import           Control.Monad.Reader (lift, liftIO, runReaderT)
-import GHC.Natural          (popCountNatural)
+import           GHC.Natural          (popCountNatural)
-import Prelude              hiding (id)
+import           Prelude              hiding (id)
-import Web.Scotty.Trans     (scottyT)
+import           Web.Scotty.Trans     (scottyT)
 
 main :: IO ()
 main = do