{-# LINE 1 "System/MountPoints.hsc" #-}
-- | 
-- Copyright: 2012 Joey Hess <id@joeyh.name>
-- License: LGPL 2.1 or higher
-- 
-- Derived from hsshellscript, originally written by
-- Volker Wysk <hsss@volker-wysk.de>

{-# LANGUAGE ForeignFunctionInterface, CPP #-}

module System.MountPoints (
	Mntent(..),
	getMounts,
	getProcMounts,
) where



import Control.Monad
import Control.Exception
import Data.Maybe
import Control.Applicative
import Foreign
import Foreign.C
import Prelude

-- | This is a stripped down mntent, containing only fields available
-- everywhere.
data Mntent = Mntent
	{ Mntent -> String
mnt_fsname :: String -- ^ what's mounted
	, Mntent -> String
mnt_dir :: FilePath  -- ^ where it's mounted
	, Mntent -> String
mnt_type :: String   -- ^ what sort of filesystem is mounted
	} deriving (Int -> Mntent -> ShowS
[Mntent] -> ShowS
Mntent -> String
(Int -> Mntent -> ShowS)
-> (Mntent -> String) -> ([Mntent] -> ShowS) -> Show Mntent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Mntent -> ShowS
showsPrec :: Int -> Mntent -> ShowS
$cshow :: Mntent -> String
show :: Mntent -> String
$cshowList :: [Mntent] -> ShowS
showList :: [Mntent] -> ShowS
Show, Mntent -> Mntent -> Bool
(Mntent -> Mntent -> Bool)
-> (Mntent -> Mntent -> Bool) -> Eq Mntent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Mntent -> Mntent -> Bool
== :: Mntent -> Mntent -> Bool
$c/= :: Mntent -> Mntent -> Bool
/= :: Mntent -> Mntent -> Bool
Eq, Eq Mntent
Eq Mntent =>
(Mntent -> Mntent -> Ordering)
-> (Mntent -> Mntent -> Bool)
-> (Mntent -> Mntent -> Bool)
-> (Mntent -> Mntent -> Bool)
-> (Mntent -> Mntent -> Bool)
-> (Mntent -> Mntent -> Mntent)
-> (Mntent -> Mntent -> Mntent)
-> Ord Mntent
Mntent -> Mntent -> Bool
Mntent -> Mntent -> Ordering
Mntent -> Mntent -> Mntent
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Mntent -> Mntent -> Ordering
compare :: Mntent -> Mntent -> Ordering
$c< :: Mntent -> Mntent -> Bool
< :: Mntent -> Mntent -> Bool
$c<= :: Mntent -> Mntent -> Bool
<= :: Mntent -> Mntent -> Bool
$c> :: Mntent -> Mntent -> Bool
> :: Mntent -> Mntent -> Bool
$c>= :: Mntent -> Mntent -> Bool
>= :: Mntent -> Mntent -> Bool
$cmax :: Mntent -> Mntent -> Mntent
max :: Mntent -> Mntent -> Mntent
$cmin :: Mntent -> Mntent -> Mntent
min :: Mntent -> Mntent -> Mntent
Ord)

-- | Get currently mounted filesystems.
--
-- This uses eiher getmntent or getmntinfo, depending on the OS.
getMounts :: IO [Mntent]

{-# LINE 39 "System/MountPoints.hsc" #-}
getMounts = do
	h <- c_mounts_start
	when (h == nullPtr) $
		throwErrno "getMounts"
	mntent <- getmntent h []
	_ <- c_mounts_end h
	return mntent
  where
	getmntent h c = do
		ptr <- c_mounts_next h
		if ptr == nullPtr
			then return (reverse c)
			else do
				mnt_fsname_str <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr >>= peekCString
{-# LINE 53 "System/MountPoints.hsc" #-}
				mnt_dir_str <- (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr >>= peekCString
{-# LINE 54 "System/MountPoints.hsc" #-}
				mnt_type_str <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr >>= peekCString
{-# LINE 55 "System/MountPoints.hsc" #-}
				let ent = Mntent
					{ mnt_fsname = mnt_fsname_str
					, mnt_dir = mnt_dir_str
					, mnt_type = mnt_type_str
					}
				getmntent h (ent:c)

{-# LINE 64 "System/MountPoints.hsc" #-}


{-# LINE 66 "System/MountPoints.hsc" #-}
-- Using unsafe imports because the C functions are belived to never block.
-- Note that getmntinfo is called with MNT_NOWAIT to avoid possibly blocking;
-- while getmntent only accesses a file in /etc (or /proc) that should not
-- block.
foreign import ccall unsafe "libmounts.h mounts_start" c_mounts_start
        :: IO (Ptr ())
foreign import ccall unsafe "libmounts.h mounts_next" c_mounts_next
        :: Ptr () -> IO (Ptr ())
foreign import ccall unsafe "libmounts.h mounts_end" c_mounts_end
        :: Ptr () -> IO CInt

{-# LINE 77 "System/MountPoints.hsc" #-}

-- | Read </proc/mounts> to get currently mounted filesystems.
-- 
-- This works on Linux and related systems, including Android. 

-- Note that on Android, `getMounts` calls this function.
getProcMounts :: IO [Mntent]
getProcMounts :: IO [Mntent]
getProcMounts = do
	Either SomeException [Mntent]
v <- IO [Mntent] -> IO (Either SomeException [Mntent])
forall e a. Exception e => IO a -> IO (Either e a)
try IO [Mntent]
go :: IO (Either SomeException [Mntent])
	[Mntent] -> IO [Mntent]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((SomeException -> [Mntent])
-> ([Mntent] -> [Mntent])
-> Either SomeException [Mntent]
-> [Mntent]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Mntent] -> SomeException -> [Mntent]
forall a b. a -> b -> a
const []) [Mntent] -> [Mntent]
forall a. a -> a
id Either SomeException [Mntent]
v)
  where
	go :: IO [Mntent]
go = (String -> Maybe Mntent) -> [String] -> [Mntent]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([String] -> Maybe Mntent
parse ([String] -> Maybe Mntent)
-> (String -> [String]) -> String -> Maybe Mntent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words) ([String] -> [Mntent])
-> (String -> [String]) -> String -> [Mntent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> [Mntent]) -> IO String -> IO [Mntent]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
"/proc/mounts"
  	parse :: [String] -> Maybe Mntent
parse (String
device:String
mountpoint:String
fstype:[String]
_rest) = Mntent -> Maybe Mntent
forall a. a -> Maybe a
Just (Mntent -> Maybe Mntent) -> Mntent -> Maybe Mntent
forall a b. (a -> b) -> a -> b
$ Mntent
		{ mnt_fsname :: String
mnt_fsname = String
device
		, mnt_dir :: String
mnt_dir = String
mountpoint
		, mnt_type :: String
mnt_type = String
fstype
		}
	parse [String]
_ = Maybe Mntent
forall a. Maybe a
Nothing