Teleport - How to write a small, useful command line application in Haskell

Star

Fork

We're going to build a command line application called teleport, It allows people to add "warp points" to navigate the file system. The warp points support creating new warp points, deleting them, and listing them.

Libraries used are:

Demo

Intended audience

The intended audience are those who are comfortable with

You'll see Haskell libraries in action, and put them together to build something tangible.

Getting the code

The code is available at the repository here (link).

To use the tutorial, a handy way of downloading and building teleport:

$ git clone https://github.com/bollu/teleport.git && cd teleport && cabal build && cabal install teleport

To use the teleport wrapper you will need, run

$ echo source `pwd`/teleport.sh >> ~/.bashrc

change ~/.bashrc to the correct shell needed

Teleport's commands

tp add <warpname> [warppath]

add a "warp point" that allows us to come back to the folder.

the default "warp path" is the current folder.

Example Usage
 # by default, teleport point is at current working directory
~/play/teleport-haskell$ tp add teleport-hs
creating teleport point:

teleport-hs /Users/bollu/play/teleport-haskell/

 # a path can be provided, which is used.
~/play/teleport-haskell$ tp add sf ~/play/software-foundations
creating teleport point:

sf  /Users/bollu/play/software-foundations

tp list

list all warp points

Example Usage
~/play/teleport-haskell$ tp list
teleport points: (total 3)
se  /Users/bollu/play/se/
sf  /Users/bollu/play/software-foundations/
tp  /Users/bollu/prog/teleport-haskell/

tp goto <warp point>

Go to the warp point. This is impossible within our application, because one process (our application, teleport) cannot change the working directory of another application (the shell).

So, there is a simple script wrapper around teleport. The wrapper runs inside the shell, so a cd is able to edit the shell's current working directory

The shell script, teleport.sh

Example Usage
~$ tp goto tp
~/p/teleport-haskell$

our current working directory changed and became the teleport-haskell folder

tp remove <warp point>

Remove an existing warp point.

Example Usage
~/play/teleport-haskell$ tp remove teleport-hs
removed teleport point [teleport-hs]

Reading the Code

Let's start reading the code, and learn about the libraries as we go along First thing's first, let us get the MIT license out of the way.

--Copyright (c) 2015 Siddharth Bhat

--Permission is hereby granted, free of charge, to any person obtaining
--a copy of this software and associated documentation files (the "Software")
--to deal in the Software without restriction, including without limitation the
--rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
--sell copies of the Software, and to permit persons to whom the Software is
--furnished to do so, subject to the following conditions:

-- The above copyright notice and this permission notice shall
-- be included in all copies or substantial portions of the Software.

--THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
--OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
--FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
--AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
--LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
--FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
--OTHER DEALINGS IN THE SOFTWARE.

The interesting code starts from here.

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

OverloadedStrings allows us to freely write code in " and have it be treated as String or Data.Text depending on context. It's a handy extension to have around.

RecordWildCards is more interesting, and I'll describe it in more detail when we get to it

import qualified Turtle
import Prelude hiding (FilePath)
import Filesystem.Path.CurrentOS as Path

Turtle is the haskell library we use to interact with the OS. It has a nice set of abstractions for dealing with OS specifics.

We choose to hide FilePath since turtle (the library for interfacing with the OS) has its own version of FilePath.

import qualified Data.Aeson as JSON
import Data.Aeson ((.=), (.:))

We use Aeson for reading and writing JSON files. We use JSON to store our settings

import Options.Applicative
import Control.Monad
import Data.Traversable
import Data.Maybe
import Data.List

These are our default imports of standard library stuff.

import qualified Data.Text as T
import qualified Data.Text.Encoding as T.Encoding
import qualified Data.ByteString.Lazy as B

We choose Text over String since the libraries that we use play along nicer with Text. String is [Char] in haskell, which is inefficient since its literally a linked list. Text uses a more efficient representation of text. Text is used internally everywhere in the application to manipulate text.

We need ByteString to read and write JSON files onto the filesystem.

import qualified System.Console.ANSI as ANSI

the ANSI library is used for coloring our outputs.

tpProgDesc :: String
tpProgDesc = "use teleport to setup teleport points and move to these " ++
               "when needed"

tpHeader :: String
tpHeader = "Teleport: move around your filesystem"

Strings that are in our library for descriptions. I prefer to keep these as constants rather than hard-code them.

-- the combined datatype representing all tp commands
data Command = CommandList |
               CommandAdd {
                    addName :: String,
                    folderPath :: FilePath
               } |
               CommandRemove {
                    removeName :: String
               } |
               CommandGoto {
                   gotoName :: String
                }
    deriving (Show)

The Command sum type represents the commands we can call on teleport, and we create subcommand datatypes to store the command that was called.

our parser returns a Command that tells us what to do.

-- | A version of 'execParser' which shows full help on error.
--
-- The regular 'execParser' only prints usage on error, which doesn't
-- include the options, subcommands, or mention of the help switch
-- @--help@.
showHelpOnErrorExecParser :: ParserInfo a -> IO a
showHelpOnErrorExecParser = customExecParser (prefs showHelpOnError)

main :: IO ()
main = do
    -- command :: Command
    command <- showHelpOnErrorExecParser (info (helper <*> parseCommand)
                       (fullDesc  <>
                        progDesc tpProgDesc <>
                        header tpHeader))
    -- run :: IO ()
    run command

Let's unpack the types in main.

parseCommand :: Parser Command

this is our core Parser which we run using showHelpOnErrorExecParser which executes the parser, and shows an error in case the parser fails to execute. If the parse succeeds, it calls run which runs command :: Command

helper :: Parser (a -> a)

helper takes any parser, and adds "help" as an option to it. We apply it to all parsers so --help works.

info :: Parser a -> InfoMod a -> ParserInfo a

info takes a parser and allows us to attach a InfoMod which adds help and display information to the parser

fullDesc :: InfoMod a
progDesc :: String -> InfoMod a
header :: String -> InfoMod a

These allow us to attach InfoMod to a Parser, which changes the information that is printed with a Parser.

They have a Monoid instance, and the <> is the mappend operator that allows us to "smash together" two modifiers into one single modifier. One can think of <> as ++ for lists: it lets us collect two lists into one.

showHelpOnErrorExecParser

As explained above, it takes a parser and allows it to show help information when the parse fails. It executed the parser passed to it (parseCommand)

parseCommand :: Parser Command
parseCommand = subparser $
    -- add command
    (command
        "add" -- command name
        (info -- attach help information to the parser
            (helper <*> parseAddCommand) -- core parser with the --help option
            (fullDesc <> progDesc "add a teleport point") -- description of command (for info)
        )
    )
    <> -- combine with the next command

    -- list command
    (command "list"
        (info (helper <*> parseListCommand)
        (fullDesc <> progDesc "list all teleport points"))
    ) <>
    -- remove command
    (command "remove"
        (info (helper <*> parseRemoveCommand)
        (fullDesc <>progDesc "remove a teleport point"))
    ) <>
    -- goto command
    (command "goto"
        (info (helper <*> parseGotoCommand)
        (fullDesc <> progDesc "go to a created teleport point"))
    )

the subparser is a function that lets us create a Parser out of a command. We smash the commands together with their monoid instance (<>).

The same use of info, fullDesc, progDesc, and helper is made as in main to attach information and help to the parser.

-- Command parsers
-- """""""""""""""

-- List
-- ----
-- $ tp list
parseListCommand :: Parser Command
parseListCommand = pure (CommandList)

the parser needs no parameters (the list command takes no options), so we use (pure :: a -> f a) to convert (CommandList :: Command) to (pure CommandList :: Parser Command)

parseAddCommand :: Parser Command
parseAddCommand = 
                   (liftA2
                        CommandAdd  -- :: String -> FilePath -> Commandd
                        tpnameParser -- :: Parser String
                        folderParser -- :: Parser FilePath
                   )

we use (liftA2 CommandAdd :: Parser String -> Parser FilePath -> Parser CommandAdd) and we pass it two parsers tpNameParser and folderParser (which is defined below) to create a Parser Command.

Till now, we were creating "command" parsers that parse:

$ tp add
$ tp list
$ ...

Now, we need to learn how to parse options, such as:

$ tp add <warp point name> ...

to do this, the general function that is used is argument.

argument :: ReadM a -> -- in general, "can be read".
            Mod ArgumentFields a -> -- modifiers to a parser
            Parser a
Let's read the code and then come back to the explanation with context:
-- Warp Name parser
-- """"""""""""""""
tpnameParser :: Parser String
tpnameParser = argument  -- :: ReadM String -> Mod ArgumentFields String -> Parser String
                  str -- :: ReadM String
                  (metavar -- :: String -> Mod ArgumentFields String
                    "NAME" <>
                  help -- :: String -> Mod ArgumentFields String
                    "name of the teleport point for usage") -- Mod ArgumentFields String
Types
Code
Use of metavar & help
$ tp add --help
Usage: teleport-exe add NAME ...
 ...
Available options:
  ...
  NAME                     name of the teleport point for usage
  ...

the NAME comes from the metavar option, and the help string comes from the help option

-- take a string, parse it into a folder path.
-- if path does not exist, return an error
readFolderPath :: String -> ReadM FilePath
readFolderPath s = do
  let path = Path.fromText (T.pack s)
  if Path.valid path
      then return path
      else readerError ("invalid path: " ++ (show path))

We convert a String to a ReadM FilePath. Since ReadM is a monad, it allows us to do error handling within it.

We return ReadM FilePath and not a FilePath to have the ability to return an error.

The (readerError :: String -> ReadM a) function allows to return an error string.

-- Folder Parser
-- """"""""""""""
folderParser :: Parser FilePath
folderParser = argument
              (str -- :: ReadM String
                >>=
               readFolderPath) -- :: String -> ReadM FilePath
              (value "./"  <>
              metavar "FOLDERPATH" <>
              help ("path of the teleport folder to teleport to." ++ 
                   "By default, taken as current working directory"))

Here, we look at how to build a more complex argument parser from the simple str argument.

parseRemoveCommand :: Parser Command
parseRemoveCommand = fmap CommandRemove tpnameParser

parseGotoCommand :: Parser Command
parseGotoCommand = fmap CommandGoto tpnameParser

Similary, we created a (CommandGoto :: Command) with the same pipeline

We have created data types to store the data for our app.

-- an abstract entity representing a point to which we can tp to
data TpPoint = TpPoint {
    name :: String,
    absFolderPath :: String
} deriving (Show)


instance JSON.FromJSON TpPoint where
     parseJSON (JSON.Object json) =
        liftA2 TpPoint (json .: "name")
                  (json .: "absFolderPath")
instance JSON.ToJSON TpPoint where
    toJSON (TpPoint {..}) =
        JSON.object [ "name" .= name
                     ,"absFolderPath" .= absFolderPath]

We'll write a TpData class which stores all the warp points together in a list.

-- the main data that is loaded from JSON
data TpData = TpData {
    tpPoints :: [TpPoint]
} deriving (Show)

instance JSON.FromJSON TpData where
    parseJSON (JSON.Object v) =
        fmap TpData (v .: "tpPoints")

instance JSON.ToJSON TpData where
    toJSON(TpData{..}) = 
        JSON.object ["tpPoints" .= tpPoints]
defaultTpData :: TpData
defaultTpData = TpData {
    tpPoints = []
}

the defaultTpData represents the default TpData that is used if no previously saved data is found (esentially, a fresh start)

filePathToString :: FilePath -> String
filePathToString = Path.encodeString

-- Data Loading
-- """"""""""""

dieJSONParseError :: FilePath -> String -> IO a
dieJSONParseError jsonFilePath err = do
    let errorstr = ("parse error in: " ++ (show jsonFilePath) ++
                    "\nerror:------\n" ++ err)
    Turtle.die (T.pack errorstr)

We write a quick function that errors out if the parse failed. To do this, we use Turtle.die that takes an error string and returns an IO a for failure.

decodeTpData :: FilePath -> IO TpData
decodeTpData jsonFilePath = do
    rawInput <- B.readFile (filePathToString jsonFilePath)
    let jsonResult = JSON.eitherDecode' rawInput

    case jsonResult of
      Left err -> dieJSONParseError jsonFilePath err
      Right json -> return json

We use JSON.eitherDecode' :: FromJSON a => ByteString -> Either String a which takes a file path and returns an Either String a with the error in Left

createTpDataFile :: FilePath -> IO ()
createTpDataFile jsonFilePath = saveTpData jsonFilePath defaultTpData

loadTpData :: FilePath -> IO TpData
loadTpData jsonFilePath = do
    exists <- (Turtle.testfile jsonFilePath)
    if exists then
        decodeTpData jsonFilePath
    else
       do
           createTpDataFile jsonFilePath
           return defaultTpData

We try to load a file. If the file does not exist, we use defaultTpData :: TpData We save this in the createTpDataFile, and then return the default value. If we do get a value, then we return the parsed object.

saveTpData :: FilePath -> TpData -> IO ()
saveTpData jsonFilePath tpData = do
    let dataBytestring = JSON.encode tpData
    Turtle.touch jsonFilePath
    B.writeFile (filePathToString jsonFilePath) dataBytestring


getTpDataPath :: IO FilePath
getTpDataPath = do
    homeFolder <- Turtle.home
    return $ homeFolder </> ".tpdata"

Note the use of Turtle for finding the home folder (Turtle.home) and to touch files (Turtle.touch). We concatenate FilePaths using (</> :: FilePath -> FilePath -> FilePath)

We're now writing functions to error out nicely with colors, since everybody likes colors :)

-- Stream Helpers
-- """"""""""""""

-- set terminal to output error color
setErrorColor :: IO ()
setErrorColor = ANSI.setSGR [-- color to set
                             ANSI.SetColor
                             -- wherther foreground / background should be affected
                             ANSI.Foreground
                             -- use the "vivid" color versus the muted colord
                             ANSI.Vivi
                             -- use red
                             ANSI.Red
                            ]    
-- print a teleport point to stdout
tpPointPrint :: TpPoint -> IO ()
tpPointPrint tpPoint = do
    ANSI.setSGR [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.White]
    putStr (name tpPoint)
    ANSI.setSGR [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Blue]    
    putStr "\t"
    putStr (absFolderPath tpPoint)
    putStr "\n"

-- error out that the given folder is not found
folderNotFoundError :: FilePath -> IO ()
folderNotFoundError path = do
    setErrorColor  
    let errorstr = T.pack ("unable to find folder: " ++ (show path)) 
    Turtle.die errorstr

-- error out that folder is required, but path points
-- to a file
needFolderNotFileError :: FilePath -> IO ()
needFolderNotFileError path = do
    setErrorColor
    let errorstr = T.pack ("expected folder, not file: " ++ (show path)) 
    Turtle.die errorstr

dieIfFolderNotFound :: FilePath -> IO ()
dieIfFolderNotFound path = 
    do
        folderExists <- Turtle.testdir path
        fileExists <- Turtle.testfile path
        -- error checking
        when fileExists (needFolderNotFileError path)
        unless folderExists (folderNotFoundError path)
       -- we know the folder exists

-- error out that the teleport point already exists
dieTpPointExists :: TpPoint -> IO ()
dieTpPointExists tpPoint  =  do
    setErrorColor
    putStrLn ("teleport point " ++ (name tpPoint) ++ " already exists:\n")
    tpPointPrint tpPoint
    Turtle.die ""

to check if the file and folder we care about exists.

Now, we're writing the run functions that tie everything up. runAdd:

if both these conditions hold true, it proceeds to create the point and save the data.
-- Add command runner
-- """"""""""""""""""

runAdd :: FilePath -> String -> IO ()
runAdd folderPath addname = do
    dieIfFolderNotFound folderPath
    tpDataPath <- getTpDataPath
    tpData <- loadTpData tpDataPath
    absFolderPath <- Turtle.realpath folderPath

    let existingTpPoint = find (\tp -> name tp == addname) (tpPoints tpData)
    case existingTpPoint of
        Just tpPoint -> dieTpPointExists tpPoint
        Nothing -> do
                        let newTpPoint = TpPoint {
                            name=addname,
                            absFolderPath=filePathToString absFolderPath
                        }

                        putStrLn "creating teleport point: \n"
                        tpPointPrint newTpPoint

                        let newTpData = TpData {
                             tpPoints= newTpPoint:(tpPoints tpData)   
                        }

                        saveTpData tpDataPath newTpData
We iterate over all the teleport points, printing them one-by-one. Since we need an "effect" to happen for each tpPoint (it needs to be printed), we use (forM_ :: (Monad m, Foldable t) => t a -> (a -> m b) -> m ()) to achieve that.
-- List Command
-- """"""""""""

runList :: IO ()
runList = do
    tpDataPath <- getTpDataPath
    tpData <- loadTpData tpDataPath
    let num_points = length $ tpPoints tpData
    putStr "teleport points: "

    ANSI.setSGR [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Blue] 
    putStr $ "(total " <> (show num_points) <>  ")\n"
    forM_ (tpPoints tpData) tpPointPrint

To remove a teleport point:


-- Remove Command
-- """""""""""""""

dieTpPointNotFound :: String ->IO ()
dieTpPointNotFound name = do
    setErrorColor
    let errorname = T.pack (name ++ " tp point not found")
    Turtle.die errorname

runRemove :: String -> IO ()
runRemove removeName = do
    tpDataPath <- getTpDataPath
    tpData <- loadTpData tpDataPath

    let wantedTpPoint = find (\tp -> name tp == removeName) (tpPoints tpData)
    case wantedTpPoint of
        Nothing -> dieTpPointNotFound removeName
        Just _ ->  do
                    let newTpPoints = filter (\tp -> name tp /= removeName)
                                               (tpPoints tpData)
                    let newTpData = tpData {
                        tpPoints = newTpPoints
                    }

                    saveTpData tpDataPath newTpData
                    ANSI.setSGR [ANSI.SetColor ANSI.Foreground
                                 ANSI.Dull ANSI.White]    
                    putStr "removed teleport point ["
                    ANSI.setSGR [ANSI.SetColor ANSI.Foreground
                                 ANSI.Vivid ANSI.Blue]    
                    putStr removeName
                    ANSI.setSGR [ANSI.SetColor ANSI.Foreground
                                 ANSI.Dull ANSI.White]    
                    putStr "]"

The proces of going to a teleport point is slightly different, since our command (teleport) cannot change the working directory of another process (the shell).

So, we:

runGoto :: String -> IO ()
runGoto gotoName = do
    tpDataPath <- getTpDataPath
    tpData <- loadTpData tpDataPath

    let wantedTpPoint = find (\tp -> name tp == gotoName) (tpPoints tpData)
    case wantedTpPoint of
        Nothing -> dieTpPointNotFound gotoName
        Just tpPoint -> do
                             Turtle.echo (T.pack (absFolderPath tpPoint))
                             Turtle.exit (Turtle.ExitFailure 2) 
teleport.sh
 #!/bin/bash
 # teleport.sh
function tp() {
    # $@ takes all arguments of the shell script
    # and passes it along to `teleport-exe`
    # which is our tool
    OUTPUT=`teleport-exe $@`
    # return code 2 tells the shell
    # script to cd to whatever `teleport` outputs
    if [ $? -eq 2 ]
        then cd "$OUTPUT"
        else echo "$OUTPUT"
    fi
}

when tp goto succeeds, we print out the path to the output stream in Haskell and returns a return code of 2. The shell script sees that the return code is 2, so it runs a cd to the correct path

If tp returns any code other than 2, the shell script echoes all the output to the screen.

Now, we see all of it together in our run function which was called by main We simply pattern match on the command and then call the correct run* function
run :: Command -> IO ()
run command = 
    case command of
        CommandAdd{..} -> runAdd folderPath addName
        CommandList -> runList
        CommandRemove{..} -> runRemove removeName
        CommandGoto{..} -> runGoto gotoName

Finale and Conclusion

Hopefully, this gave you a decent overview on how to combine libraries and use all of them in Haskell. If there are any bugs/comments, please do report them at the github repository