diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2013, Kazuo Koga + +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. 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/src/System/Authenticate/SmbClient.hs b/src/System/Authenticate/SmbClient.hs new file mode 100644 --- /dev/null +++ b/src/System/Authenticate/SmbClient.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Authenticate.SmbClient ( + loginSmbClient + ) where + +import Control.Applicative +import Data.Char +import Data.Maybe +import Data.Text hiding (head) +import Prelude hiding (unlines, null, takeWhile) +import System.Exit +import System.Process +import System.Timeout + +commandName = "smbclient" + +-- |Authenticate with @smbclient@ command. +-- +-- Return True if login success, False otherwise. +-- +-- This does not accept empty username or password, +-- because those has always been success as Guest login. +loginSmbClient :: Text -- ^ Server + -> Text -- ^ Domain + -> Text -- ^ Username + -> Text -- ^ Password + -> IO Bool +loginSmbClient server domain username password = do + timedResult <- timeout (10 * 1000000) process + case timedResult of + Just result -> return result + Nothing -> return False + where + domain' = checkedText domain + username' = checkedText username + password' = checkedText password + authInfo dom usr pas = [ + "username = " `append` usr, + "password = " `append` pas, + "domain = " `append` dom] + authInfo' = + unpack <$> unlines + <$> (authInfo <$> domain' <*> username' <*> password') + process = + case authInfo' of + Just a -> validate commandName server a + _ -> return False + +validate command server authInfo = do + (exitCode, _, _) <- + readProcessWithExitCode command [ + "-L", unpack server, + "-A", "/dev/stdin"] + authInfo + case exitCode of + ExitSuccess -> return True + _ -> return False + +-- |Returns valid words or Nothing. +-- +-- >>> checkedText $ pack "hello" +-- Just "hello" +-- >>> checkedText $ pack " hello" +-- Just "hello" +-- >>> checkedText $ pack "hell o " +-- Just "hell o" +-- >>> checkedText $ pack "\npassword=" +-- Nothing +-- >>> checkedText $ pack "hello\npassword=" +-- Just "hello" +-- >>> checkedText $ pack " " +-- Nothing +-- >>> checkedText $ pack "\n" +-- Nothing +-- >>> checkedText $ pack " \n" +-- Nothing +-- >>> checkedText $ pack "\t" +-- Nothing +checkedText = noneEmptyText . trimWhite . takeUntilNewline + where + noneEmptyText text = + if null text + then Nothing + else Just text + takeUntilNewline = + takeWhile (not . isControl) + trimWhite = + dropAround isSpace diff --git a/sys-auth-smbclient.cabal b/sys-auth-smbclient.cabal new file mode 100644 --- /dev/null +++ b/sys-auth-smbclient.cabal @@ -0,0 +1,81 @@ +-- Initial sys-auth-smbclient.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: sys-auth-smbclient + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 1.0.0.0 + +-- A short (one-line) description of the package. +synopsis: Auth with smbclient command + +-- A longer description of the package. +description: This module provides a interface for executing + @smbclient@ commands. + +-- The license under which the package is released. +license: MIT + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Kazuo Koga + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: Kazuo Koga + +-- A copyright notice. +copyright: (c) 2013 Kazuo Koga + +homepage: https://github.com/kkazuo/sys-auth-smbclient +bug-reports: https://github.com/kkazuo/sys-auth-smbclient/issues + +category: System + +build-type: Simple + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.14 + + +library + default-language: Haskell2010 + hs-source-dirs: src + + ghc-options: -Wall + -fno-warn-missing-signatures + + -- Modules exported by the library. + exposed-modules: System.Authenticate.SmbClient + + -- Modules included in this library but not exported. + -- other-modules: + + -- Other library packages from which modules are imported. + build-depends: base < 5 + , process >= 1.1 + , text >= 0.11 + + +test-suite doctest + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + ghc-options: -threaded -Wall + main-is: doctests.hs + build-depends: base + , doctest > 0.9 + + +source-repository this + type: git + location: https://github.com/kkazuo/sys-auth-smbclient.git + tag: 1.0.0.0 diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,6 @@ +module Main where + +import Test.DocTest + +main :: IO () +main = doctest ["src/System/Authenticate/SmbClient.hs"]