puffytools (empty) → 0.0.0.1
raw patch · 17 files changed
+1097/−0 lines, 17 filesdep +MissingHdep +QuickCheckdep +aesonsetup-changed
Dependencies added: MissingH, QuickCheck, aeson, aeson-pretty, base, bytestring, console-program, containers, directory, old-locale, puffytools, random-fu, safe, test-framework, test-framework-quickcheck2, text, time, vector
Files
- LICENSE +30/−0
- README.md +162/−0
- Setup.hs +2/−0
- ptk/Main.hs +49/−0
- ptk/Ptk/Journal.hs +45/−0
- ptk/Ptk/Journal/AddEntry.hs +57/−0
- ptk/Ptk/Journal/Cat.hs +43/−0
- ptk/Ptk/Journal/List.hs +45/−0
- ptk/Ptk/Journal/ListEntries.hs +70/−0
- ptk/Ptk/Journal/New.hs +63/−0
- puffytools.cabal +99/−0
- res/usage.txt +10/−0
- src/PuffyTools/Journal.hs +179/−0
- src/PuffyTools/Slug.hs +82/−0
- test/Test.hs +31/−0
- test/TestPuffyToolsJournal.hs +105/−0
- test/TestPuffyToolsSlug.hs +25/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Peter Harpending++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Peter Harpending nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,162 @@+# puffytools, version 0.0.0.1++This is the Puffy Toolkit, or Ptk. Ptk is a command-line "personal assistant",+of sorts. Currently, it will keep journals. I'm adding more functionality as I+can. Pull requests are welcome, although do read the "Development version"+section below.++# Installation and usage++You can install the experimental version from Hackage. If you use Windows or OS+X, you'll need to install the+[Haskell Platform](https://www.haskell.org/platform/). On Linux or BSD, your+distribution should have the packages `ghc` and `cabal-install`. The GHC version+must be 7.8 or later. Install those, then run:++ cabal update+ cabal install puffytools++If the installation fails, you may need to install an updated version of+`cabal-install`, `alex`, and `happy`:++ cabal install cabal-install alex happy+ cabal install puffytools++## Development version++If you want the development version, the steps are a bit different. ++ git clone git://github.com/pharpend/puffytools.git -b develop+ cd puffytools+ cabal sandbox init+ cabal install --enable-tests++I use `gitflow` as a branching model, so+[read about that](http://nvie.com/posts/a-successful-git-branching-model/) if+you have never heard about it. I don't particularly care what branching model+you use, as long as you don't commit to the `master` or `develop` branches.++## Usage++```+ptk+The Puffy Toolkit, version 0.0.0++ j+ Same as journal.+ + add_entry slug STRING+ Add an entry to journal with a given slug. The second argument is the entry text.+ + + ae slug STRING+ Same as add_entry+ + + cat slug+ Output the raw journal+ + + list+ List all of the available journals+ + + ls+ Same as list+ + + list_entries JOURNAL_SLUG+ List the entries in a given journal+ --time-format=STRING,+ --strftime=STRING The format with which to print timestamps. See `man strftime` for more information.+ + + le JOURNAL_SLUG+ Same as listEntries+ --time-format=STRING,+ --strftime=STRING The format with which to print timestamps. See `man strftime` for more information.+ + + new+ Create a new journal+ -sSTRING,+ -nSTRING --slug=STRING,+ --name=STRING The slug/short name of the journal.+ -tSTRING --title=STRING The title of the journal+ -dSTRING --description=STRING The journal Description+ + + help+ Show help for the journal module+ + + + journal+ Do things with Journals+ + add_entry slug STRING+ Add an entry to journal with a given slug. The second argument is the entry text.+ + + ae slug STRING+ Same as add_entry+ + + cat slug+ Output the raw journal+ + + list+ List all of the available journals+ + + ls+ Same as list+ + + list_entries JOURNAL_SLUG+ List the entries in a given journal+ --time-format=STRING,+ --strftime=STRING The format with which to print timestamps. See `man strftime` for more information.+ + + le JOURNAL_SLUG+ Same as listEntries+ --time-format=STRING,+ --strftime=STRING The format with which to print timestamps. See `man strftime` for more information.+ + + new+ Create a new journal+ -sSTRING,+ -nSTRING --slug=STRING,+ --name=STRING The slug/short name of the journal.+ -tSTRING --title=STRING The title of the journal+ -dSTRING --description=STRING The journal Description+ + + help+ Show help for the journal module+ + + + help+ Show this help menu.+ + + version+ Print the version to the console. Meant for use in other programs.+ + + shell+ PTK REPL (Expiremental).+``` ++# Licensing++Like most Haskell packages, Ptk is licensed under the BSD-3 license. You can see+the [`LICENSE` file][2] for more information.+ +[1]: https://github.com/bitemyapp/learnhaskell+[2]: https://github.com/pharpend/puffytools/blob/develop/LICENSE+[3]: https://github.com/pharpend/puffytools/blob/develop/ptkbuild
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ptk/Main.hs view
@@ -0,0 +1,49 @@+{- |+Module : Main+Description : Runs the puffy tool kit (ptk)+Copyright : 2014, Peter Harpending+License : BSD3+Maintainer : Peter Harpending <pharpend2@gmail.com>+Stability : experimental+Portability : Linux++-}++module Main where++import Data.Version+import Paths_puffytools+import Ptk.Journal+import System.Console.Argument+import System.Console.Command+import System.Console.Program++versionTree :: Commands IO+versionTree = Node commandVersion []+ where+ commandVersion = Command+ "version"+ "Print the version to the console. Meant for use in other programs."+ printVersion+ printVersion = io . putStr $ showVersion version++helpTree :: Commands IO+helpTree = Node helpCommand []+ where+ helpCommand = Command "help" "Show this help menu." help++shellTree :: Commands IO+shellTree = Node ptkShell []+ where+ ptkShell = Command "shell" "PTK REPL (Expiremental)." (io $ interactive commandTree)++help :: Action IO+help = io $ showUsage commandTree++commandTree :: Commands IO+commandTree = Node (Command "ptk" description help) [jTree, journalTree, helpTree, versionTree, shellTree]+ where+ description = "The Puffy Toolkit, version " ++ showVersion version++main :: IO ()+main = single commandTree
+ ptk/Ptk/Journal.hs view
@@ -0,0 +1,45 @@+{- |+Module : Ptk.Journal+Description : `ptk journal` command tree for the puffy toolkit+Copyright : 2014, Peter Harpending+License : BSD3+Maintainer : Peter Harpending <pharpend2@gmail.com>+Stability : experimental+Portability : Linux++-}++module Ptk.Journal (jTree, journalTree, journalHelp) where++import Data.Traversable+import PuffyTools.Journal+import Ptk.Journal.AddEntry+import Ptk.Journal.Cat+import Ptk.Journal.List+import Ptk.Journal.ListEntries+import Ptk.Journal.New+import System.Console.Argument+import System.Console.Command+import System.Console.Program++subCommandList = [ journalAddEntryTree+ , journalAETree+ , journalCatTree+ , journalListTree+ , journalLsTree+ , journalListEntriesTree+ , journalLeTree+ , journalNewTree+ , journalHelpTree+ ]+journalTree :: Commands IO+journalTree = Node journalCommand subCommandList+ where+ journalCommand = Command "journal" "Do things with Journals" journalHelp++jTree = Node jCommand subCommandList+ where jCommand = Command "j" "Same as journal." journalHelp++journalHelpTree = Node (Command "help" "Show help for the journal module" journalHelp) []++journalHelp = io $ showUsage journalTree
+ ptk/Ptk/Journal/AddEntry.hs view
@@ -0,0 +1,57 @@+{- |+Module : Ptk.Journal.AddEntry+Description : `ptk journal add_entry` command tree+Copyright : 2014, Peter Harpending+License : BSD3+Maintainer : Peter Harpending <pharpend2@gmail.com>+Stability : experimental+Portability : Linux++-}++module Ptk.Journal.AddEntry (journalAETree, journalAddEntryTree, journalAddEntryHelp) where++import Data.Monoid+import Data.Text (Text, pack, unpack)+import PuffyTools.Journal+import PuffyTools.Slug+import System.Console.Argument +import System.Console.Command hiding (name)+import System.Console.Program (showUsage)+import qualified Data.Vector as V++journalAddEntryHelp :: Action IO+journalAddEntryHelp = io $ showUsage journalAddEntryTree++-- |Same as add_entry+journalAETree = Node aeCommand []+ where+ aeCommand = Command "ae" "Same as add_entry" aeAction++-- |This is basically the tree of things that get parsed when the+-- luser runs "ptk journal AddEntry"+journalAddEntryTree :: Commands IO+journalAddEntryTree = Node addEntryCommand []+ where+ addEntryCommand = Command+ "add_entry"+ "Add an entry to journal with a given slug. The second argument is the entry text."+ aeAction++aeAction :: Action IO+aeAction = withNonOption slugType $ \slg -> withNonOption string (runAE slg)++slugType :: Type Slug+slugType = Type {parser = \s -> mkSlugEither (pack s)+ ,name = "slug"+ ,defaultValue = Nothing}++-- |Run the `ptk journal add_entry` command+runAE :: Slug -> String -> Action IO+runAE slug entryStr = io $ do+ unlessJournal (unSlug slug) $ do+ fail $ "Journal does not exist: " <> (unpack $ unSlug slug)+ jl <- readJournalDef slug+ ety <- mkEntry (pack entryStr)+ let nj = jl { journalEntries = journalEntries jl <> V.singleton ety }+ writeJournal nj
+ ptk/Ptk/Journal/Cat.hs view
@@ -0,0 +1,43 @@+{- |+Module : Ptk.Journal.Cat+Description : `ptk journal cat` command tree+Copyright : 2014, Peter Harpending+License : BSD3+Maintainer : Peter Harpending <pharpend2@gmail.com>+Stability : experimental+Portability : Linux++-}++module Ptk.Journal.Cat (journalCatTree, journalCatHelp) where++import Control.Applicative+import qualified Data.ByteString as B+import Data.Text (Text, pack, unpack)+import PuffyTools.Journal+import PuffyTools.Slug+import System.Console.Argument +import System.Console.Command hiding (name)+import System.Console.Program++journalCatHelp :: Action IO+journalCatHelp = io $ showUsage journalCatTree++-- |This is basically the tree of things that get parsed when the+-- luser runs "ptk journal cat"+journalCatTree :: Commands IO+journalCatTree = Node catCommand []+ where+ -- This is a "Command" object - basically says that the subcommand+ -- is "cat", and it has an associated description.+ catCommand = Command "cat" "Output the raw journal" $ withNonOption slugType runCat++slugType :: Type Slug+slugType = Type {parser = \s -> mkSlugEither (pack s)+ ,name = "slug"+ ,defaultValue = Nothing}+ +-- |Run the `ptk journal cat` command+runCat :: Slug -> Action IO +runCat slug = io $ do+ B.putStrLn =<< B.readFile =<< generateSlugPath slug
+ ptk/Ptk/Journal/List.hs view
@@ -0,0 +1,45 @@+{- |+Module : Ptk.Journal.List+Description : `ptk journal list` command tree+Copyright : 2014, Peter Harpending+License : BSD3+Maintainer : Peter Harpending <pharpend2@gmail.com>+Stability : experimental+Portability : Linux++-}++module Ptk.Journal.List (journalLsTree, journalListTree, journalListHelp) where++import Control.Applicative+import qualified Data.Text.IO as Tio+import PuffyTools.Journal+import PuffyTools.Slug+import System.Console.Argument+import System.Console.Command+import System.Console.Program+import System.Directory++journalListHelp :: Action IO+journalListHelp = io $ showUsage journalListTree++journalLsTree :: Commands IO+journalLsTree = Node lsCommand []+ where+ lsCommand = Command "ls" "Same as list" listJournalsCmd++journalListTree :: Commands IO+journalListTree = Node listCommand []+ where+ listCommand = Command "list" "List all of the available journals" listJournalsCmd++listJournalsCmd :: Action IO+listJournalsCmd = io $ do+ journals <- mapM readJournalFromFile =<< listJournals+ case journals of+ [] -> putStrLn "You haven't created any journals."+ js -> mapM_ (Tio.putStrLn . unSlug . journalSlug) journals+dirOption :: IO (Option FilePath)+dirOption = option "d" ["dir", "directory"] directory <$> getAppUserDataDirectory "puffytools"+ <*> pure+ "The directory in which to look for journals."
+ ptk/Ptk/Journal/ListEntries.hs view
@@ -0,0 +1,70 @@+{- |+Module : Ptk.Journal.ListEntries+Description : `ptk journal listEntries` command tree+Copyright : 2014, Peter Harpending+License : BSD3+Maintainer : Peter Harpending <pharpend2@gmail.com>+Stability : experimental+Portability : Linux++-}++module Ptk.Journal.ListEntries (journalLeTree, journalListEntriesTree, journalListEntriesHelp) where++import Control.Applicative+import Control.Monad ((<=<))+import Data.List (sort)+import Data.Monoid (mconcat)+import Data.Ord (comparing)+import Data.Text (Text, pack, unpack)+import qualified Data.Text.IO as Tio+import Data.Time+import Data.Vector (toList)+import PuffyTools.Journal+import PuffyTools.Slug+import System.Console.Argument+import System.Console.Command hiding (name)+import System.Console.Program+import System.Directory+import System.Locale (defaultTimeLocale)++journalListEntriesHelp :: Action IO+journalListEntriesHelp = io $ showUsage journalListEntriesTree++journalLeTree :: Commands IO+journalLeTree = Node leCommand []+ where+ leCommand = Command "le" "Same as listEntries" listEntriesOptions++journalListEntriesTree :: Commands IO+journalListEntriesTree = Node listEntriesCommand []++listEntriesCommand = Command "list_entries" "List the entries in a given journal" listEntriesOptions+ +listEntriesOptions = (withNonOption slugType (\slg -> withOption strftimeOption (listEntriesAction+ slg)))+strftimeOption :: Option String+strftimeOption = option "" ["time-format", "strftime"] string "%x %X %Z"+ "The format with which to print timestamps. See `man strftime` for more information."++slugType :: Type Slug+slugType = Type {parser = \s -> mkSlugEither (pack s)+ ,name = "JOURNAL_SLUG"+ ,defaultValue = Nothing}++instance Ord Entry where+ compare = comparing entryCreated++listEntriesAction :: Slug -> String -> Action IO+listEntriesAction slg timeFormat = io $ do+ j <- readJournalDef slg+ let etys = journalEntries j+ sorted_etys = sort $ toList etys+ mapM_ (\ety -> Tio.putStrLn =<< formatEntry ety) sorted_etys + where+ formatEntry ety = do+ time <- formattedTime $ entryCreated ety+ return $ mconcat [pack time, "\t", entrySummary ety]+ formattedTime :: UTCTime -> IO String+ formattedTime = fmap (formatTime defaultTimeLocale timeFormat) . utcToLocalZonedTime+
+ ptk/Ptk/Journal/New.hs view
@@ -0,0 +1,63 @@+{- |+Module : Ptk.Journal.New+Description : `ptk journal new` command tree+Copyright : 2014, Peter Harpending+License : BSD3+Maintainer : Peter Harpending <pharpend2@gmail.com>+Stability : experimental+Portability : Linux++-}++module Ptk.Journal.New (journalNewTree, journalNewHelp) where++import Data.Text (Text, pack, unpack)+import PuffyTools.Journal+import PuffyTools.Slug+import System.Console.Argument +import System.Console.Command hiding (name)+import System.Console.Program++journalNewHelp :: Action IO+journalNewHelp = io $ showUsage journalNewTree++-- |This is basically the tree of things that get parsed when the+-- luser runs "ptk journal new"+journalNewTree :: Commands IO+journalNewTree = Node newCommand []+ where+ -- This is a "Command" object - basically says that the subcommand+ -- is "new", and it has an associated description.+ newCommand = Command "new" "Create a new journal" $ withOption slugOption doSlug+ -- This is an option to specify the name of the journal+ slugOption = option "sn" ["slug", "name"] string "default"+ "The slug/short name of the journal."+ -- title+ titleOption = option "t" ["title"] string "" "The title of the journal"+ -- title+ descOption = option "d" ["description"] string "" "The journal Description"++ doSlug slug = withOption titleOption (doTitle slug)+ doTitle slug title = withOption descOption (runNJ slug title)++slugType :: Type Slug+slugType = Type {parser = \s -> mkSlugEither (pack s)+ ,name = "slug"+ ,defaultValue = Nothing}+-- |Run the `ptk journal new` command+runNJ+ :: String -- ^The slug+ -> String -- ^The title+ -> String -- ^The description+ -> Action IO -- ^The resultant action+runNJ sslug stitle sdesc = io $ do+ let slug = pack sslug+ title = pack stitle+ desc = case pack sdesc of+ "" -> Nothing+ x -> Just x+ ifJournal slug $ do+ fail "Journal already exists"+ mdJournal <- mkJournal =<< mkSlugIO slug+ let newJournal = mdJournal { journalTitle = title }+ writeJournal newJournal
+ puffytools.cabal view
@@ -0,0 +1,99 @@+-- Initial mittens.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: puffytools+version: 0.0.0.1+synopsis: A CLI assistant+description:+ A CLI-based "personal assistant." It will keep journal entries, remind you of+ things, remind others of things, keep dates for you, etc.+homepage: https://github.com/pharpend/puffytools+bug-reports: https://github.com/pharpend/puffytools/issues+license: BSD3+license-file: LICENSE+author: Peter Harpending+maintainer: pharpend2@gmail.com+copyright: 2014, Peter Harpending+category: Utility+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10+data-files:+ README.md+ , LICENSE+ , res/usage.txt++library+ default-language: Haskell2010+ hs-source-dirs: src/+ ghc-options: -Wall -fno-warn-orphans+ default-extensions:+ FlexibleInstances+ OverloadedStrings+ build-depends:+ aeson >=0.7+ , aeson-pretty >=0.7+ , bytestring >=0.10 && <0.11+ , base >=4 && <4.8+ , containers >=0.5 && <0.6+ , directory >=1.2 && <1.3+ , MissingH >=1.3 && <1.4+ , random-fu >=0.2 && <0.3+ , safe >=0.3 && <0.4+ , text >=0.10+ , time >=1.4 + , vector >=0.10 && <0.11+ exposed-modules:+ Paths_puffytools+ PuffyTools.Journal+ PuffyTools.Slug++executable ptk+ main-is: Main.hs+ ghc-options: -Wall+ hs-source-dirs: ptk/+ default-language: Haskell2010+ default-extensions:+ OverloadedStrings+ build-depends:+ base >=4 && <4.8+ , bytestring+ , console-program >=0.3.2 && <0.4+ , directory >=1.2 && <1.3+ , old-locale >=1.0+ , puffytools+ , vector+ , time >=1.4 && <1.5+ , text >=0.10+ other-modules:+ Ptk.Journal+ Ptk.Journal.AddEntry+ Ptk.Journal.Cat+ Ptk.Journal.List+ Ptk.Journal.ListEntries+ Ptk.Journal.New++source-repository head+ type: git+ location: git://github.com/pharpend/puffytools.git++test-suite tests+ hs-source-dirs: test+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ ghc-options: -Wall -fno-warn-orphans+ main-is: Test.hs+ other-modules:+ TestPuffyToolsJournal+ TestPuffyToolsSlug+ build-depends:+ aeson >=0.7 && <0.9+ , base >=4.7 && <4.8+ , bytestring >=0.10 && <0.11+ , puffytools+ , QuickCheck >=2.7 && <2.8+ , test-framework >=0.8 && <0.9+ , test-framework-quickcheck2 >=0.3 && <0.4+ , text >=1.1 && <1.3+ , time >=1.4 && <1.5+ , vector >=0.10 && <0.11
+ res/usage.txt view
@@ -0,0 +1,10 @@+mittens, v.0.0.0, by Peter Harpending <pharpend2@gmail.com>.++Mittens is used via a client, called `mtn`. Note that these subcommands should+not be preceded with a hyphen. That is, run `mtn help` rather than `mtn --help`.++ OPTION THING IT DOES+ ----------------------------------------------+ h, help, usage Print this page+ license Print the license (BSD-3).+ version Print the version
+ src/PuffyTools/Journal.hs view
@@ -0,0 +1,179 @@+{- |+Module : PuffyTools.Journal+Description : A Journal-keeping thing+Copyright : 2014, Peter Harpending+License : BSD3+Maintainer : Peter Harpending <pharpend2@gmail.com>+Stability : experimental+Portability : Linux++-}++module PuffyTools.Journal where++import Control.Applicative+import Data.Aeson+import Data.Aeson.Encode.Pretty+import Data.Monoid+import qualified Data.ByteString as Bs+import qualified Data.ByteString.Lazy as B+import Data.List.Utils+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time+import Data.Vector (Vector)+import qualified Data.Vector as V+import PuffyTools.Slug+import System.Directory+import System.IO++programName :: String+programName = "puffytools"++journalExt :: String+journalExt = ".journal"++-- |A Journal is really a wrapper around a list of entries+data Journal = Journal { journalSlug :: Slug+ , journalTitle :: Text+ , journalLastEdited :: UTCTime+ , journalCreated :: UTCTime+ , journalDescription :: Maybe Text+ , journalEntries :: Vector Entry+ }+ deriving (Show, Eq)++-- |Entries+data Entry = Entry { entrySummary :: Text+ , entryCreated :: UTCTime+ , entryLastEdited :: UTCTime+ }+ deriving (Show, Eq)++instance FromJSON Journal where+ parseJSON (Object v) = Journal <$> v .: "slug"+ <*> v .: "title"+ <*> v .: "last-edited"+ <*> v .: "created"+ <*> v .: "description"+ <*> v .: "entries"+ parseJSON _ = fail "Must be an object"++instance ToJSON Journal where+ toJSON (Journal s t le cr des ent) = object+ [ "slug" .= s+ , "title" .= t+ , "last-edited" .= le+ , "created" .= cr+ , "description" .= des+ , "entries" .= ent+ ]++instance FromJSON Entry where+ parseJSON (Object v) = Entry <$> v .: "summary"+ <*> v .: "created"+ <*> v .: "last-edited"+ parseJSON _ = fail "Not an object"++instance ToJSON Entry where+ toJSON e = object [ "summary" .= entrySummary e+ , "created" .= entryCreated e+ , "last-edited" .= entryLastEdited e+ ]++addEntry :: Journal -> Entry -> Journal+addEntry j e = j { journalEntries = newEntries }+ where newEntries = journalEntries j `V.snoc` e++mkEntry :: Text -> IO Entry+mkEntry entryText = Entry entryText <$> getCurrentTime <*> getCurrentTime++-- |Makes a journal, given a slug+mkJournal :: Slug -> IO Journal+mkJournal s = getCurrentTime >>= \t -> return $ Journal s mempty t t mempty mempty++-- |Makes a journal, given a slug+mkJournal' :: Text -> IO Journal+mkJournal' s = mkSlugIO s >>= mkJournal++-- |Figures out the file path for a journal+generateJournalPath :: Journal -> IO FilePath+generateJournalPath j = do+ dataDir <- getAppUserDataDirectory programName+ return $ mconcat [dataDir, "/", (T.unpack . unSlug . journalSlug) j, journalExt]++generateSlugPath :: Slug -> IO FilePath+generateSlugPath slg = do+ ddir <- getAppUserDataDirectory programName+ let fullPath = mconcat [ddir, "/", T.unpack $ unSlug slg, journalExt]+ return fullPath++-- |Writes a journal to a file path+writeJournal :: Journal -> IO ()+writeJournal j = do pth <- generateJournalPath j; B.writeFile pth $ encodePretty j++-- |Reads a journal from the default file path (~/.puffytools/journal-title.json)+readJournalName :: Text -> IO Journal+readJournalName name = do+ slg <- case mkSlugEither name of+ Left err -> fail err+ Right s -> return s+ generateSlugPath slg >>= readJournalFromFile++-- |Reads a journal from the default file path (~/.puffytools/journal-title.json)+readJournalDef :: Slug -> IO Journal+readJournalDef slg = generateSlugPath slg >>= readJournalFromFile++-- |Reads a journal, given a file path+readJournalFromFile :: FilePath -> IO Journal+readJournalFromFile fp = openFile fp ReadMode >>= readJournalFromHandle++-- |Reads a journal from a handle, close handle+readJournalFromHandle :: Handle -> IO Journal+readJournalFromHandle h = do+ handleBytes <- Bs.hGetContents h+ case eitherDecodeStrict' handleBytes of+ Left err -> fail err+ Right j -> return j+ +{-# DEPRECATED listJournals "use listJournalFiles instead"#-}+listJournals :: IO [FilePath]+listJournals = listJournalFiles++-- |List all of the journal file paths+listJournalFiles :: IO [FilePath]+listJournalFiles = do+ ddr <- ddir+ fps <- filter (endswith ".journal") <$> allDataFiles+ return $ map (\fp -> mconcat [ddr, "/", fp]) fps++ where+ ddir = getAppUserDataDirectory programName+ allDataFiles = do+ d <- ddir+ d `seq` createDirectoryIfMissing True d+ getDirectoryContents d++-- |List all of the Journal slugs+listJournalSlugs :: IO [Text]+listJournalSlugs = do+ fps <- listJournalFiles+ journals <- mapM readJournalFromFile fps+ let slugs = map (unSlug . journalSlug) journals+ pure slugs++-- |Perform some action if a given journal exists+ifJournal :: Text -> IO () -> IO ()+ifJournal slg doStuff = do+ jss <- listJournalSlugs+ if slg `elem` jss+ then doStuff+ else return ()++-- |Perform some action if a given journal does not exist+unlessJournal :: Text -> IO () -> IO ()+unlessJournal slg doStuff = do+ jss <- listJournalSlugs+ if not (slg `elem` jss)+ then doStuff+ else return ()
+ src/PuffyTools/Slug.hs view
@@ -0,0 +1,82 @@+{- |+Module : PuffyTools.Slug+Description : Generate slugs+Copyright : 2014, Peter Harpending+License : BSD3+Maintainer : Peter Harpending <pharpend2@gmail.com>+Stability : experimental+Portability : Linux++These generate slugs (file names).++The slug must be alphanumeric, with the exception of "-_". It also+must be between 4 and 32 chars long.+-}++module PuffyTools.Slug (+ Slug,+ mkSlugMaybe,+ mkSlugEither,+ mkRandomSlug,+ mkSlugIO,+ slugAcceptChars,+ unSlug,+ ) where++import Control.Applicative+import Control.Monad+import Data.Aeson+import Data.Monoid ((<>))+import Data.Random+import Data.Text (Text)+import qualified Data.Text as T++-- |Newtype wrapper for String+newtype Slug = MkSlug { unSlug :: Text }+ deriving (Eq, Show)++-- |Maybe make a Slug+mkSlugMaybe :: Text -> Maybe Slug+mkSlugMaybe s = case mkSlugEither s of+ Left _ -> Nothing+ Right q -> Just q++-- |Try to make a Slug, return an error if I can't+mkSlugEither :: Text -> Either String Slug+mkSlugEither s+ | T.length s < 1 = Left "The slug must be at least 4 chars long."+ | ftb /= s = Left $ "The slug may only contain these characters: " <> slugAcceptChars+ | otherwise = Right $ MkSlug s+ where+ -- ftb ~ "filter badness"+ ftb :: Text+ ftb = T.filter (\c -> c `elem` slugAcceptChars) s++mkSlugIO :: Text -> IO Slug+mkSlugIO t = case mkSlugEither t of+ Left msg -> fail msg+ Right slg -> return slg++-- |Generates a random slug 32 chars long+mkRandomSlug :: IO Slug+mkRandomSlug = T.pack <$> (replicateM 32 ioc) >>= \s -> case mkSlugEither s of+ Left err -> fail err+ Right slg -> return slg+ where+ ioc :: IO Char+ ioc = runRVar rvc StdRandom+ rvc :: RVar Char+ rvc = randomElement slugAcceptChars++-- |Acceptable characters for a slug+slugAcceptChars :: String+slugAcceptChars = ['A' .. 'Z'] <> ['a' .. 'z'] <> ['0' .. '9'] <> "-_"++instance FromJSON Slug where+ parseJSON (String s) = case mkSlugEither s of+ Left err -> fail err+ Right slg -> return slg+ parseJSON _ = fail "Slug must be of type String."++instance ToJSON Slug where+ toJSON (MkSlug s) = toJSON s
+ test/Test.hs view
@@ -0,0 +1,31 @@+{- |+Module : Main+Description : Test the PuffyTools journal functions+Copyright : 2014, Peter Harpending+License : BSD3+Maintainer : Peter Harpending <pharpend2@gmail.com>+Stability : experimental+Portability : Linux++-}++module Main where++import Data.Char+import Data.List+import PuffyTools.Journal+import TestPuffyToolsJournal+import Test.Framework+import Test.Framework.Providers.QuickCheck2++main :: IO ()+main = defaultMain tests++tests :: [Test]+tests = [testGroup "PuffyTools.Journal"+ [testGroup "Aeson properties"+ [ testProperty "(encode . decode . encode) = (encode)" prop_encDecEnc+ , testProperty "(decode . encode . decode . encode) = (decode . encode)"+ prop_decEncDecEnc+ , testProperty "(decode . encode . decode . encode)^n = (decode . encode)" prop_dEn+ ]]]
+ test/TestPuffyToolsJournal.hs view
@@ -0,0 +1,105 @@+{- |+Module : TestPuffyToolsJournal+Description : Test the PuffyTools journal functions+Copyright : 2014, Peter Harpending+License : BSD3+Maintainer : Peter Harpending <pharpend2@gmail.com>+Stability : experimental+Portability : Linux++-}++module TestPuffyToolsJournal where++import Control.Applicative ((<$>), (<*>), pure)+import Control.Monad ((<=<))+import Data.Aeson+import qualified Data.Text as T+import Data.Time+import qualified Data.Vector as V+import PuffyTools.Journal+import System.IO.Unsafe+import TestPuffyToolsSlug ()+import Test.QuickCheck++-- |So, it turns out, encoding & decoding isn't an identity. However,+-- (encode . decode . encode) = encode, and (decode . encode . decode)+-- = decode+-- +-- https://github.com/liyang/thyme/issues/12+-- +-- First, (encode . decode . encode) = (encode)+prop_encDecEnc :: Journal -> Bool+prop_encDecEnc j = Just (encode j) == (encode <$> (de j))++-- |This is (decode . encode . decode . encode) = (encode . decode)+prop_decEncDecEnc :: Journal -> Bool+prop_decEncDecEnc j = (de <=< de) j == de j++-- |For the hell of it, we'll decode/encode a bunch of times+prop_dEn+ :: Journal -- ^Journal + -> Natural -- ^Number of times to execute decode/encode+ -> Bool+prop_dEn j n = de j == foldl (\journal _ -> de =<< journal) (de j) [(Natural 1) .. n]++-- |This is a helper function+de :: Journal -> Maybe Journal+de = decode . encode++-- +-- For reference+-- +-- -- |A Journal is really a wrapper around a list of entries+-- data Journal = Journal { journalTitle :: Text+-- , journalLastEdited :: UTCTime+-- , journalCreated :: UTCTime+-- , journalDescription :: Maybe Text+-- , journalEntries :: Vector Entry+-- }+-- deriving (Show, Eq)++-- -- |Entries+-- data Entry = Entry { entrySummary :: Text+-- , entryCreated :: UTCTime+-- , entryLastEdited :: UTCTime+-- , entryDescription :: Maybe Text+-- }+-- deriving (Show, Eq)++instance Arbitrary T.Text where+ arbitrary = T.pack <$> arbitrary++instance Arbitrary UTCTime where+ arbitrary = pure $ unsafePerformIO getCurrentTime ++instance Arbitrary Entry where+ arbitrary = Entry <$> arbitrary <*> arbitrary <*> arbitrary ++instance Arbitrary x => Arbitrary (V.Vector x) where+ arbitrary = V.fromList <$> arbitrary++instance Arbitrary Journal where+ arbitrary = Journal <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary++-- This type is NOT isomorphic!+newtype Natural = Natural { unNatural :: Int }+ deriving (Eq, Show)++instance Enum Natural where+ toEnum = mkNatural+ fromEnum = unNatural++mkNatural :: Int -> Natural+mkNatural i+ | i < 0 = Natural $ (-1) * i+ | i == 0 = Natural 1+ | otherwise = Natural i++instance Arbitrary Natural where+ arbitrary = mkNatural <$> arbitrary
+ test/TestPuffyToolsSlug.hs view
@@ -0,0 +1,25 @@+{- |+Module : TestPuffyToolsSlug+Description : Test the PuffyTools.Slug module+Copyright : 2014, Peter Harpending+License : BSD3+Maintainer : Peter Harpending <pharpend2@gmail.com>+Stability : experimental+Portability : Linux++-}++module TestPuffyToolsSlug where++import Control.Applicative+import PuffyTools.Slug+import Data.Text (pack)+import Test.QuickCheck++instance Arbitrary Slug where+ arbitrary = do+ slugLength <- elements [4 .. 32]+ slugCandidate <- pack <$> take slugLength <$> infiniteListOf (elements slugAcceptChars)+ case mkSlugEither slugCandidate of+ Left err -> fail err+ Right slg -> return slg