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:

optparse-applicative : parsing command line arguments

: parsing command line arguments Aeson : reading/writing JSON

: reading/writing Turtle : writing "shell"-y code for files and directories

: writing "shell"-y code for files and directories ANSI : emit colors in the console

: emit colors in the console Text and Bytestring : forced to use these because of Aeson , Filepath

Demo

Intended audience

The intended audience are those who are comfortable with

Functor, Applicative, Monad and do notation

notation IO (no other monads required)

(no other monads required) general haskell patterns

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.

CommandAdd needs the name of the warp point to add, and the path to the folder

needs the name of the warp point to add, and the path to the folder CommandRemove needs the name of the warp point to remove

needs the name of the warp point to remove CommandGoto needs the name of the warp point to go to

needs the name of the warp point to go to Command is the data type that allows us to combine this information.

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 command s 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

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

ReadM a is a way to "read something in". Let's start with the ReadM instance (str :: ReadM String) and use the Functor and Monad instance on str create new ReadM instances. For more on ReadM , click here

Mod ArgumentFields a allows us to modify a Parser by providing it with modifiers. The modifiers have a Monoid instance, which allows us to smash them together with mappend

Code

start with a str :: ReadM String

use the metavar option to give it a name

option to give it a name use the help option to give it a help string.

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.

The composition of (str :: ReadM String) with (readFolderPath :: String -> ReadM FilePath) using (>>=) gives us a function that takes a raw string, tries to parse it to a folder and fails if the parse fails.

The (value :: HasValue f a => a -> Mod f a) lets us define a default value to the "folder" option. We set the default to "." (the current folder)

parseRemoveCommand :: Parser Command parseRemoveCommand = fmap CommandRemove tpnameParser parseGotoCommand :: Parser Command parseGotoCommand = fmap CommandGoto tpnameParser

tpnameParser :: Parser String is used to parse names.

is used to parse names. ( CommandRemove :: String -> Command ) converts String =CommandRemove=> Command

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

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

TpPoint stores the information of a warp point.

stores the information of a warp point. FromJSON and ToJSON typeclasses for TpPoint to allow it to store and retreive JSON

-- 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" )

FromJSON is to convert a JSON object to a TpPoint .

is to convert a object to a . (Object json) :: Value is our parameter, and we need to creae a TpPoint .

We use the ( (.:) :: FromJSON a => Object -> Text -> Parser a) operator, which when given a JSON Object and a key, gives us a Parser a

the Parser has an applicative instance, so we lift our TpPoint to the Parser type with liftA2

Here, we also see RecordWildCards (the extension) at play. It automatically "unpacks" the TpPoint for us, and we can directly access name and absFoldeerPath

The syntax of {..} is used to denote that this declaration must be unpacked

instance JSON.ToJSON TpPoint where toJSON ( TpPoint { .. }) = JSON.object [ "name" .= name , "absFolderPath" .= absFolderPath]

(toJSON :: a -> Value) is used to create a JSON Value from an object a . For us, the (a ~ TpPoint) .

To create a Value , we use (JSON.object :: object :: [Pair] -> Value) . We give it an array of Pair objects and it creates a Value (JSON Value).

We use ( (.=) :: ToJSON v => Text -> v -> (kv ~ Pair) ) to pair up a key with a Value . the .= creates any KeyValue . We use it to create a Pair .

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) ++ "

error:------

" ++ 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 FilePath s 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 ]

setSGR :: [SGR] -> IO () lets us color the output. It takes an array of SGR (Select Graphic Rendition) objects, and applies them.

The SGR instance we use in Teleport are SetColor :: ConsoleLayer ColorIntensity Color -> SGR to add colors to our output

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

" -- 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:

" ) tpPointPrint tpPoint Turtle.die ""

Turtle.testdir :: MonadIO io => FilePath -> io Bool allows us to check if the directory exists

allows us to check if the directory exists Turtle.testfile :: MonadIO io => FilePath -> io Bool lets us check if the file exists

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

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

Checks that the teleport point is valid.

Checks that there is no other point of the same name.

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

" tpPointPrint newTpPoint let newTpData = TpData { tpPoints = newTpPoint : (tpPoints tpData) } saveTpData tpDataPath newTpData

tpPoint

( forM_ :: ( Monad m, Foldable t) => t a -> (a -> m b) -> m ())

-- 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) <> ")

" forM_ (tpPoints tpData) tpPointPrint

To remove a teleport point:

check if a teleport point with the name exists

If it does, filter it out and save the rest of the points

Otherwise, print an error

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

run teleport (the executable) within a shell script ( teleport.sh )

(the executable) within a shell script ( ) return a special value ( 2 ) to the person who runs teleport (which is teleport.sh )

) to the person who runs (which is ) have teleport.sh execute a cd when it detects a return value of 2 .

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.

run

main

run*

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