diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ptk/Main.hs b/ptk/Main.hs new file mode 100644 --- /dev/null +++ b/ptk/Main.hs @@ -0,0 +1,49 @@ +{- | +Module : Main +Description : Runs the puffy tool kit (ptk) +Copyright : 2014, Peter Harpending +License : BSD3 +Maintainer : Peter Harpending +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 diff --git a/ptk/Ptk/Journal.hs b/ptk/Ptk/Journal.hs new file mode 100644 --- /dev/null +++ b/ptk/Ptk/Journal.hs @@ -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 +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 diff --git a/ptk/Ptk/Journal/AddEntry.hs b/ptk/Ptk/Journal/AddEntry.hs new file mode 100644 --- /dev/null +++ b/ptk/Ptk/Journal/AddEntry.hs @@ -0,0 +1,57 @@ +{- | +Module : Ptk.Journal.AddEntry +Description : `ptk journal add_entry` command tree +Copyright : 2014, Peter Harpending +License : BSD3 +Maintainer : Peter Harpending +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 diff --git a/ptk/Ptk/Journal/Cat.hs b/ptk/Ptk/Journal/Cat.hs new file mode 100644 --- /dev/null +++ b/ptk/Ptk/Journal/Cat.hs @@ -0,0 +1,43 @@ +{- | +Module : Ptk.Journal.Cat +Description : `ptk journal cat` command tree +Copyright : 2014, Peter Harpending +License : BSD3 +Maintainer : Peter Harpending +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 diff --git a/ptk/Ptk/Journal/List.hs b/ptk/Ptk/Journal/List.hs new file mode 100644 --- /dev/null +++ b/ptk/Ptk/Journal/List.hs @@ -0,0 +1,45 @@ +{- | +Module : Ptk.Journal.List +Description : `ptk journal list` command tree +Copyright : 2014, Peter Harpending +License : BSD3 +Maintainer : Peter Harpending +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." diff --git a/ptk/Ptk/Journal/ListEntries.hs b/ptk/Ptk/Journal/ListEntries.hs new file mode 100644 --- /dev/null +++ b/ptk/Ptk/Journal/ListEntries.hs @@ -0,0 +1,70 @@ +{- | +Module : Ptk.Journal.ListEntries +Description : `ptk journal listEntries` command tree +Copyright : 2014, Peter Harpending +License : BSD3 +Maintainer : Peter Harpending +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 + diff --git a/ptk/Ptk/Journal/New.hs b/ptk/Ptk/Journal/New.hs new file mode 100644 --- /dev/null +++ b/ptk/Ptk/Journal/New.hs @@ -0,0 +1,63 @@ +{- | +Module : Ptk.Journal.New +Description : `ptk journal new` command tree +Copyright : 2014, Peter Harpending +License : BSD3 +Maintainer : Peter Harpending +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 diff --git a/puffytools.cabal b/puffytools.cabal new file mode 100644 --- /dev/null +++ b/puffytools.cabal @@ -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 diff --git a/res/usage.txt b/res/usage.txt new file mode 100644 --- /dev/null +++ b/res/usage.txt @@ -0,0 +1,10 @@ +mittens, v.0.0.0, by Peter Harpending . + +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 diff --git a/src/PuffyTools/Journal.hs b/src/PuffyTools/Journal.hs new file mode 100644 --- /dev/null +++ b/src/PuffyTools/Journal.hs @@ -0,0 +1,179 @@ +{- | +Module : PuffyTools.Journal +Description : A Journal-keeping thing +Copyright : 2014, Peter Harpending +License : BSD3 +Maintainer : Peter Harpending +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 () diff --git a/src/PuffyTools/Slug.hs b/src/PuffyTools/Slug.hs new file mode 100644 --- /dev/null +++ b/src/PuffyTools/Slug.hs @@ -0,0 +1,82 @@ +{- | +Module : PuffyTools.Slug +Description : Generate slugs +Copyright : 2014, Peter Harpending +License : BSD3 +Maintainer : Peter Harpending +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 diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,31 @@ +{- | +Module : Main +Description : Test the PuffyTools journal functions +Copyright : 2014, Peter Harpending +License : BSD3 +Maintainer : Peter Harpending +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 + ]]] diff --git a/test/TestPuffyToolsJournal.hs b/test/TestPuffyToolsJournal.hs new file mode 100644 --- /dev/null +++ b/test/TestPuffyToolsJournal.hs @@ -0,0 +1,105 @@ +{- | +Module : TestPuffyToolsJournal +Description : Test the PuffyTools journal functions +Copyright : 2014, Peter Harpending +License : BSD3 +Maintainer : Peter Harpending +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 diff --git a/test/TestPuffyToolsSlug.hs b/test/TestPuffyToolsSlug.hs new file mode 100644 --- /dev/null +++ b/test/TestPuffyToolsSlug.hs @@ -0,0 +1,25 @@ +{- | +Module : TestPuffyToolsSlug +Description : Test the PuffyTools.Slug module +Copyright : 2014, Peter Harpending +License : BSD3 +Maintainer : Peter Harpending +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